File Coverage

File:	lib/Netspoc.pm
Coverage:	81.3%

line	stmt	bran	cond	sub	pod	time	code
1							package Netspoc;
2
3 - 27							=head1 NAME Netspoc - A Network Security Policy Compiler =head1 COPYRIGHT AND DISCLAIMER (c) 2015 by Heinz Knutzen <heinz.knutzen@googlemail.com> http://hknutzen.github.com/Netspoc This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2 of the License, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA. =cut
28
29	70 70 70			70		233 71 1656	use strict;
30	70 70 70			70		257 67 1544	use warnings;
31	70 70 70			70		16874 134 4632	use Module::Load::Conditional qw(can_load);
32							my $can_json = can_load( modules => {JSON => 0.0} ) and JSON->import();
33	70 70 70			70		11955 115 228	use open qw(:std :utf8);
34	70 70 70			70		16032 94 5311	use Encode;
35							my $filename_encode = 'UTF-8';
36
37							# VERSION: inserted by DZP::OurPkgVersion
38							my $program = 'Network Security Policy Compiler';
39							my $version = __PACKAGE__->VERSION \|\| 'devel';
40
41	70 70 70			70		272 74 1757714	use Exporter;
42							our @ISA = qw(Exporter);
43							our @EXPORT = qw(
44							%routers
45							%interfaces
46							%networks
47							%hosts
48							%owners
49							%areas
50							%pathrestrictions
51							%groups
52							%protocols
53							%protocolgroups
54							%services
55							%isakmp
56							%ipsec
57							%crypto
58							%expanded_rules
59							$error_counter
60							store_description
61							fast_mode
62							get_config_keys
63							get_config_pattern
64							check_config_pair
65							read_config
66							set_config
67							info
68							progress
69							abort_on_error
70							set_abort_immediately
71							err_msg
72							fatal_err
73							unique
74							equal
75							read_ip
76							print_ip
77							show_version
78							split_typed_name
79							is_network
80							is_router
81							is_interface
82							is_host
83							is_subnet
84							is_every
85							is_group
86							is_protocolgroup
87							is_objectgroup
88							is_chain
89							is_autointerface
90							read_netspoc
91							read_file
92							read_file_or_dir
93							show_read_statistics
94							order_protocols
95							link_topology
96							mark_disabled
97							set_zone
98							set_service_owner
99							expand_services
100							expand_crypto
101							check_unused_groups
102							setpath
103							path_walk
104							find_active_routes_and_statics
105							check_supernet_rules
106							optimize_and_warn_deleted
107							distribute_nat_info
108							gen_reverse_rules
109							mark_secondary_rules
110							rules_distribution
111							local_optimization
112							check_output_dir
113							print_code );
114
115							####################################################################
116							# User configurable options.
117							####################################################################
118
119							# Valid values:
120							# - Default: 0\|1
121							# - Option with name "check_*": 0,1,'warn'
122							# - 0: no check
123							# - 1: throw an error if check fails
124							# - warn: print warning if check fails
125							# - Option with name "max_*": integer
126							# Other: string
127							our %config = (
128
129							# Check for unused groups and protocolgroups.
130							check_unused_groups => 'warn',
131
132							# Check for unused protocol definitions.
133							check_unused_protocols => 0,
134
135							# Allow subnets only
136							# - if the enclosing network is marked as 'has_subnets' or
137							# - if the subnet is marked as 'subnet_of'
138							check_subnets => 'warn',
139
140							# Check for unenforceable rules, i.e. no managed device between src and dst.
141							check_unenforceable => 'warn',
142
143							# Check for duplicate rules.
144							check_duplicate_rules => 'warn',
145
146							# Check for redundant rules.
147							check_redundant_rules => 'warn',
148
149							# Check for services where owner can't be derived.
150							check_service_unknown_owner => 0,
151
152							# Check for services where multiple owners have been derived.
153							check_service_multi_owner => 'warn',
154
155							# Check for missing supernet rules.
156							check_supernet_rules => 'warn',
157
158							# Check for transient supernet rules.
159							check_transient_supernet_rules => 'warn',
160
161							# Optimize the number of routing entries per router:
162							# For each router find the hop, where the largest
163							# number of routing entries points to
164							# and replace them with a single default route.
165							# This is only applicable for internal networks
166							# which have no default route to the internet.
167							auto_default_route => 1,
168
169							# Add comments to generated code.
170							comment_acls => 0,
171							comment_routes => 0,
172
173							# Ignore these names when reading directories:
174							# - CVS and RCS directories
175							# - CVS working files
176							# - Editor backup files: emacs: *~
177							ignore_files => '^(CVS\|RCS\|\.#.\|.~)$',
178
179							# Abort after this many errors.
180							max_errors => 10,
181
182							# Print progress messages.
183							verbose => 1,
184
185							# Print progress messages with time stamps.
186							# Print "finished" with time stamp when finished.
187							time_stamps => 0,
188							);
189
190							# Valid values for config options in %config.
191							# Key is prefix or string "default".
192							# Value is pattern for checking valid values.
193							our %config_type = (
194							check_ => '0\|1\|warn',
195							max_ => '\d+',
196							ignore_ => '\S+',
197							_default => '0\|1',
198							);
199
200							sub get_config_keys {
201	305			305	0	1236	return keys %config;
202							}
203
204							sub valid_config_key {
205	0			0	0	0	my ($key) = @_;
206	0					0	return exists $config{$key};
207							}
208
209							sub get_config_pattern {
210	5188			5188	0	4322	my ($key) = @_;
211	5188					3591	my $pattern;
212	5188					8013	for my $prefix (keys %config_type) {
213	15358	100				108320	if ($key =~ /^$prefix/) {
214	3662					3901	$pattern = $config_type{$prefix};
215	3662					3810	last;
216							}
217							}
218	5188		67			15648	return $pattern \|\| $config_type{_default};
219							}
220
221							# Checks for valid config key/value pair.
222							# Returns false on success, the expected pattern on failure.
223							sub check_config_pair {
224	3			3	0	5	my ($key, $value) = @_;
225	3					4	my $pattern = get_config_pattern($key);
226	3	50				93	return ($value =~ /^($pattern)$/ ? undef : $pattern);
227							}
228
229							# Set %config with pairs from one or more hashrefs.
230							# Rightmost hash overrides previous values with same key.
231							sub set_config {
232	337			337	0	475	my (@hrefs) = @_;
233	337					438	for my $href (@hrefs) {
234	663					1722	while (my ($key, $val) = each %$href) {
235	388					1274	$config{$key} = $val;
236							}
237							}
238	337					514	return;
239							}
240
241							# Modified only by sub store_description.
242							my $new_store_description;
243
244							sub store_description {
245	13			13	0	18	my ($set) = @_;
246	13	100				27	if (defined $set) {
247	11					18	return($new_store_description = $set);
248							}
249							else {
250	2					5	return $new_store_description;
251							}
252							}
253
254							my $fast_mode;
255							sub fast_mode {
256	947			947	0	899	my ($set) = @_;
257	947	100				1278	if (defined $set) {
258	305					360	return($fast_mode = $set);
259							}
260							else {
261	642					1328	return $fast_mode;
262							}
263							}
264
265							# Use non-local function exit for efficiency.
266							# Perl profiler doesn't work if this is active.
267							my $use_nonlocal_exit => 1;
268
269							####################################################################
270							# Attributes of supported router models
271							####################################################################
272							my %router_info = (
273							IOS => {
274							routing => 'IOS',
275							filter => 'IOS',
276							stateless => 1,
277							stateless_self => 1,
278							stateless_icmp => 1,
279							inversed_acl_mask => 1,
280							can_vrf => 1,
281							can_log_deny => 1,
282							log_modifiers => { 'log-input' => ':subst' },
283							has_out_acl => 1,
284							need_protect => 1,
285							crypto => 'IOS',
286							print_interface => 1,
287							comment_char => '!',
288							extension => {
289							EZVPN => { crypto => 'EZVPN' },
290							FW => { stateless => 0 },
291							},
292							},
293							'NX-OS' => {
294							routing => 'NX-OS',
295							filter => 'NX-OS',
296							stateless => 1,
297							stateless_self => 1,
298							stateless_icmp => 1,
299							can_objectgroup => 1,
300							inversed_acl_mask => 1,
301							use_prefix => 1,
302							can_vrf => 1,
303							can_log_deny => 1,
304							log_modifiers => {},
305							has_out_acl => 1,
306							need_protect => 1,
307							print_interface => 1,
308							comment_char => '!',
309							},
310							'ACE' => {
311							routing => 'IOS',
312							filter => 'ACE',
313							stateless => 0,
314							stateless_self => 0,
315							stateless_icmp => 1,
316							can_objectgroup => 1,
317							inversed_acl_mask => 0,
318							use_prefix => 0,
319							can_vrf => 0,
320							can_log_deny => 0,
321							log_modifiers => {},
322							has_vip => 1,
323							has_out_acl => 1,
324							need_protect => 1,
325							print_interface => 1,
326							comment_char => '!',
327							},
328							PIX => {
329							routing => 'PIX',
330							filter => 'PIX',
331							stateless_icmp => 1,
332							can_objectgroup => 1,
333							comment_char => '!',
334							has_interface_level => 1,
335							need_identity_nat => 1,
336							no_filter_icmp_code => 1,
337							need_acl => 1,
338							},
339
340							# Like PIX, but without identity NAT.
341							ASA => {
342							routing => 'PIX',
343							filter => 'PIX',
344							log_modifiers => { emergencies => 0,
345							alerts => 1,
346							critical => 2,
347							errors => 3,
348							warnings => 4,
349							notifications => 5,
350							informational => 6,
351							debugging => 7,
352							disable => 'disable',
353							},
354							stateless_icmp => 1,
355							has_out_acl => 1,
356							can_objectgroup => 1,
357							can_dyn_crypto => 1,
358							crypto => 'ASA',
359							no_crypto_filter => 1,
360							comment_char => '!',
361							has_interface_level => 1,
362							no_filter_icmp_code => 1,
363							need_acl => 1,
364							extension => {
365							VPN => {
366							crypto => 'ASA_VPN',
367							stateless_tunnel => 1,
368							do_auth => 1,
369							},
370							EZVPN => { crypto => 'ASA_EZVPN' },
371							'8.4' => { v8_4 => 1, },
372							},
373							},
374							Linux => {
375							routing => 'iproute',
376							filter => 'iptables',
377							has_io_acl => 1,
378							comment_char => '#',
379							can_managed_host => 1,
380							},
381							);
382							for my $model (keys %router_info) {
383
384							# Is changed for model with extension. Used in error messages.
385							$router_info{$model}->{name} = $model;
386
387							# Is left unchanged with extensions. Used in header of generated files.
388							$router_info{$model}->{class} = $model;
389							}
390
391							# Use this if src or dst port isn't defined.
392							# Don't allocate memory again and again.
393							my $aref_tcp_any = [ 1, 65535 ];
394
395							# Definition of dynamic routing protocols.
396							# Protocols get {up} relation in order_protocols.
397							my %routing_info;
398
399							# Definition of redundancy protocols.
400							# Protocols get {up} relation in order_protocols.
401							my %xxrp_info;
402
403							## no critic (RequireArgUnpacking)
404
405							# All arguments are 'eq'.
406							sub equal {
407	53	100		53	0	108	return 1 if not @_;
408	43					39	my $first = shift;
409	43 47					56 167	return not grep { $_ ne $first } @_;
410							}
411
412							# Unique union of all elements.
413							# Preserves original order.
414							sub unique {
415	1062			1062	0	844	my %seen;
416	1062 1091					1418 4947	return grep { !$seen{$_}++ } @_;
417							}
418
419							sub find_duplicates {
420	67			67	0	58	my %dupl;
421	67					183	$dupl{$_}++ for @_;
422	67 77					119 291	return grep { $dupl{$_} > 1 } keys %dupl;
423							}
424
425							sub intersect {
426	3			3	0	4	my ($aref1, $aref2) = @_;
427	3 3					3 9	my %seen = map { $_ => 1 } @$aref1;
428	3 3					3 9	return grep { $seen{$_} } @$aref2;
429							}
430
431							sub max {
432	0			0	0	0	my $max = shift(@_);
433	0					0	for my $el (@_) {
434	0	0				0	$max = $el if $max < $el;
435							}
436	0					0	return $max;
437							}
438
439							# Delete an element from an array reference.
440							# Return 1 if found, undef otherwise.
441							sub aref_delete {
442	163			163	0	154	my ($aref, $elt) = @_;
443	163					283	for (my $i = 0 ; $i < @$aref ; $i++) {
444	199	100				421	if ($aref->[$i] eq $elt) {
445	163					172	splice @$aref, $i, 1;
446
447							#debug("aref_delete: $elt->{name}");
448	163					292	return 1;
449							}
450							}
451	0					0	return;
452							}
453
454							# Compare two array references element wise.
455							sub aref_eq {
456	1390			1390	0	1186	my ($a1, $a2) = @_;
457	1390	100				2474	return if @$a1 ne @$a2;
458	1131					1867	for (my $i = 0 ; $i < @$a1 ; $i++) {
459	98	100				244	return if $a1->[$i] ne $a2->[$i];
460							}
461	1109					1622	return 1;
462							}
463
464							sub keys_eq {
465	36			36	0	40	my ($href1, $href2) = @_;
466	36	100				80	keys %$href1 == keys %$href2 or return;
467	22					37	for my $key (keys %$href1) {
468	25	100				65	exists $href2->{$key} or return;
469							}
470	16					42	return 1;
471							}
472
473							my $start_time;
474
475							sub info {
476	1542	50		1542	0	2558	return if not $config{verbose};
477	0					0	print STDERR @_, "\n";
478	0					0	return;
479							}
480
481							sub progress {
482	6727	50		6727	0	11206	return if not $config{verbose};
483	0	0				0	if ($config{time_stamps}) {
484	0					0	my $diff = time() - $start_time;
485	0					0	printf STDERR "%3ds ", $diff;
486							}
487	0					0	info(@_);
488	0					0	return;
489							}
490
491							sub warn_msg {
492	72			72	0	1492	print STDERR "Warning: ", @_, "\n";
493	72					171	return;
494							}
495
496							sub debug {
497	0	0		0	0	0	return if not $config{verbose};
498	0					0	print STDERR @_, "\n";
499	0					0	return;
500							}
501							## use critic
502
503							# Name of current input file.
504							our $current_file;
505
506							# Rules and objects read from directories and files with
507							# special name 'xxx.private' are marked with attribute {private} = 'xxx'.
508							# This variable is used to propagate the value from directories to its
509							# files and sub-directories.
510							our $private;
511
512							# Content of current file.
513							our $input;
514
515							# Current line number of input file.
516							our $line;
517
518							sub context {
519	0			0	0	0	my $context;
520	0	0				0	if (pos $input == length $input) {
521	0					0	$context = 'at EOF';
522							}
523							else {
524	0					0	my ($pre, $post) =
525							$input =~ m/([^ \t\n,;={}][,;={} \t])\G([,;={} \t][^ \t\n,;={}])/;
526	0					0	$context = qq/near "$pre<--HERE-->$post"/;
527							}
528	0					0	return qq/ at line $line of $current_file, $context\n/;
529							}
530
531							sub at_line {
532	12			12	0	299	return qq/ at line $line of $current_file\n/;
533							}
534
535							our $error_counter;
536							our $abort_immediately;
537
538							sub check_abort {
539	124			124	0	112	$error_counter++;
540	124	50 50				355	if ($error_counter == $config{max_errors}) {
541	0					0	die "Aborted after $error_counter errors\n";
542							}
543							elsif ($abort_immediately) {
544	0					0	die "Aborted\n";
545							}
546							}
547
548							sub abort_on_error {
549	542	100		542	0	1270	die "Aborted with $error_counter error(s)\n" if $error_counter;
550	450					390	return;
551							}
552
553							sub set_abort_immediately {
554	208			208	0	176	$abort_immediately = 1;
555	208					172	return;
556							}
557
558							sub error_atline {
559	12			12	0	19	my (@args) = @_;
560	12					24	print STDERR "Error: ", @args, at_line();
561	12					23	check_abort();
562	12					16	return;
563							}
564
565							sub err_msg {
566	112			112	0	186	my (@args) = @_;
567	112					2811	print STDERR "Error: ", @args, "\n";
568	112					180	check_abort();
569	112					241	return;
570							}
571
572							sub fatal_err {
573	5			5	0	6	my (@args) = @_;
574	5					55	print STDERR "Error: ", @args, "\n";
575	5					27	die "Aborted\n";
576							}
577
578							sub syntax_err {
579	0			0	0	0	my (@args) = @_;
580	0					0	die "Syntax error: ", @args, context();
581							}
582
583							sub internal_err {
584	0			0	0	0	my (@args) = @_;
585
586							# Don't show inherited error.
587							# Abort immediately, if other errors have already occured.
588	0	0				0	if ($error_counter) {
589	0					0	die "Aborted after $error_counter errors\n";
590							}
591	0					0	my (undef, $file, $line) = caller;
592	0					0	my $sub = (caller 1)[3];
593	0					0	my $msg = "Internal error in $sub";
594	0	0				0	$msg .= ": @args" if @args;
595
596	0					0	die "$msg\n at $file line $line\n";
597							}
598
599							####################################################################
600							# Helper functions for reading configuration
601							####################################################################
602
603							# $input is used as input buffer, it holds content of current input file.
604							# Progressive matching is used. \G is used to match current position.
605							sub skip_space_and_comment {
606
607							# Ignore trailing white space and comments.
608	112983			112983	0	285320	while ($input =~ m'\G[ \t](?:[#].)?(?:\n\|$)'gc) {
609	9655					22976	$line++;
610							}
611
612							# Ignore leading white space.
613	112983					119016	$input =~ m/\G[ \t]*/gc;
614	112983					93870	return;
615							}
616
617							# Optimize use of CORE:regcomp. Build regex only once for each token.
618							my %token2regex;
619
620							# Check for a string and skip if available.
621							sub check {
622	96427			96427	0	75156	my $token = shift;
623	96427					99103	skip_space_and_comment;
624	96427		67			273837	my $regex = $token2regex{$token} \|\|= qr/\G$token/;
625	96427					415506	return $input =~ /$regex/gc;
626							}
627
628							# Skip a string.
629							sub skip {
630	19078			19078	0	16319	my $token = shift;
631	19078		50			20448	return(check $token or syntax_err("Expected '$token'"));
632							}
633
634							# Check, if an integer is available.
635							sub check_int {
636	1617			1617	0	1711	skip_space_and_comment;
637	1617	100				2860	if ($input =~ m/\G(\d+)/gc) {
638	1591					3221	return $1;
639							}
640							else {
641	26					52	return;
642							}
643							}
644
645							sub read_int {
646	1272			1272	0	1420	my $result = check_int();
647	1272	50				2088	defined $result or syntax_err("Integer expected");
648	1272					2144	return $result;
649							}
650
651							# Read IP address. Internally it is stored as an integer.
652							sub check_ip {
653	2771			2771	0	2935	skip_space_and_comment;
654	2771	50				8082	if ($input =~ m/\G(\d+)\.(\d+)\.(\d+)\.(\d+)/gc) {
655	2771	50	20			20983	if ($1 > 255 or $2 > 255 or $3 > 255 or $4 > 255) {
656	0					0	error_atline("Invalid IP address");
657							}
658	2771					8715	return unpack 'N', pack 'C4', $1, $2, $3, $4;
659							}
660							else {
661	0					0	return;
662							}
663							}
664
665							sub read_ip {
666	2771			2771	0	3446	my $result = check_ip();
667	2771	50				4509	defined $result or syntax_err("IP address expected");
668	2771					3063	return $result;
669							}
670
671							# Read IP address and prefix length.
672							# x.x.x.x/n
673							sub read_ip_prefix {
674	1232			1232	0	2341	my $ip = read_ip;
675	1232					1588	skip('/');
676	1232					1746	my $mask = prefix2mask(read_int());
677	1232	50				1926	defined $mask or syntax_err('Invalid prefix');
678	1232	100				1567	match_ip($ip, $ip, $mask) or error_atline("IP and mask don't match");
679
680							# Prevent further errors.
681	1232					1164	$ip &= $mask;
682	1232					1941	return $ip, $mask;
683							}
684
685							sub read_ip_prefix_pair {
686	77			77	0	90	my ($ip, $mask) = read_ip_prefix();
687	77					130	return [ $ip, $mask ];
688							}
689
690							sub gen_ip {
691	4500			4500	0	3802	my ($byte1, $byte2, $byte3, $byte4) = @_;
692	4500					9510	return unpack 'N', pack('C4', $byte1, $byte2, $byte3, $byte4);
693							}
694
695							# Convert IP address from internal integer representation to
696							# readable string.
697							sub print_ip {
698	2866			2866	0	2406	my $ip = shift;
699	2866					7977	return sprintf "%vd", pack 'N', $ip;
700							}
701
702							# Conversion from netmask to prefix and vice versa.
703							{
704
705							# Initialize private variables of this block.
706							my %mask2prefix;
707							my %prefix2mask;
708							for my $prefix (0 .. 32) {
709							my $mask = 232 - 2(32 - $prefix);
710							$mask2prefix{$mask} = $prefix;
711							$prefix2mask{$prefix} = $mask;
712							}
713
714							# Convert a network mask to a prefix ranging from 0 to 32.
715							sub mask2prefix {
716	1752			1752	0	1526	my $mask = shift;
717	1752					2602	return $mask2prefix{$mask};
718							}
719
720							sub prefix2mask {
721	3602			3602	0	2871	my $prefix = shift;
722	3602					5124	return $prefix2mask{$prefix};
723							}
724							}
725
726							sub complement_32bit {
727	4555			4555	0	3553	my ($ip) = @_;
728	4555					5608	return ~$ip & 0xffffffff;
729							}
730
731							# Check if $ip1 is located inside network $ip/$mask.
732							sub match_ip {
733	3585			3585	0	3712	my ($ip1, $ip, $mask) = @_;
734	3585					8493	return ($ip == ($ip1 & $mask));
735							}
736
737							sub read_identifier {
738	1337			1337	0	1467	skip_space_and_comment;
739	1337	50				2995	if ($input =~ m/(\G[\w-]+)/gc) {
740	1337					2636	return $1;
741							}
742							else {
743	0					0	syntax_err("Identifier expected");
744							}
745							}
746
747							# Pattrern for attribute "visible": "" or "name".
748							sub read_owner_pattern {
749	0			0	0	0	skip_space_and_comment;
750	0	0				0	if ($input =~ m/ ( \G [\w-]* [*] ) /gcx) {
751	0					0	return $1;
752							}
753							else {
754	0					0	syntax_err("Pattern '' or 'name' expected");
755							}
756							}
757
758							# Used for reading hardware name, model, admins, watchers.
759							sub read_name {
760	1751			1751	0	1969	skip_space_and_comment;
761	1751	50				4035	if ($input =~ m/(\G[^;,\s""'']+)/gc) {
762	1751					3528	return $1;
763							}
764							else {
765	0					0	syntax_err("String expected");
766							}
767							}
768
769							# Used for reading alias name or radius attributes.
770							sub read_string {
771	35			35	0	43	skip_space_and_comment;
772	35	50				66	if ($input =~ m/\G([^;,""''\n]+)/gc) {
773	35					64	return $1;
774							}
775							else {
776	0					0	syntax_err("String expected");
777							}
778							}
779
780							# Object representing 'user'.
781							# This is only 'active' while parsing src or dst of the rule of a service.
782							my $user_object = { active => 0, refcount => 0, elements => undef };
783
784							sub read_union {
785	728			728	0	707	my ($delimiter) = @_;
786	728					564	my @vals;
787	728					700	my $count = $user_object->{refcount};
788	728					877	push @vals, read_intersection();
789	728					1360	my $has_user_ref = $user_object->{refcount} > $count;
790	728					613	my $user_ref_error = 0;
791	728					558	while (1) {
792	745	100				875	last if check $delimiter;
793	17					29	my $comma_seen = check ',';
794
795							# Allow trailing comma.
796	17	50				33	last if check $delimiter;
797
798	17	50				36	$comma_seen or syntax_err("Comma expected in union of values");
799	17					25	$count = $user_object->{refcount};
800	17					26	push @vals, read_intersection();
801	17		33			73	$user_ref_error \|\|=
802							$has_user_ref != ($user_object->{refcount} > $count);
803							}
804							$user_ref_error
805	728	50				1169	and error_atline("The sub-expressions of union equally must\n",
806							" either reference 'user' or must not reference 'user'");
807	728					1232	return @vals;
808							}
809
810							# Check for xxx:xxx \| router:xx@xx \| network:xx/xx \| interface:xx/xx
811							sub check_typed_name {
812	5622			5622	0	5871	skip_space_and_comment;
813	5622	100				16418	$input =~ m/ \G (\w+) : /gcx or return;
814	4062					6295	my $type = $1;
815	4062					3086	my ($name, $separator);
816	4062	50				10730	if ($input =~ m' \G ( [\w-]+ (?: ( [@/] ) [\w-]+ )? ) 'gcx) {
817	4062					4723	$name = $1;
818	4062					4206	$separator = $2;
819							}
820							else {
821	0					0	syntax_err("Invalid token");
822							}
823
824	4062	100				5729	if ($separator) {
825	46	100 50	67			135	if ($type eq 'router') {
826	6	50				12	$separator eq '@' or syntax_err("Invalid token");
827							}
828							elsif ($type eq 'network' or $type eq 'interface') {
829	40	50				63	$separator eq '/' or syntax_err("Invalid token");
830							}
831							else {
832	0					0	syntax_err("Invalid token");
833							}
834							}
835	4062					11224	return [ $type, $name ];
836							}
837
838							sub read_typed_name {
839	1727		33	1727	0	1916	return check_typed_name \|\| syntax_err("Typed name expected");
840							}
841
842							{
843
844							# user@domain or @domain
845							my $domain_regex = qr/(?:[\w-]+\.)+[\w-]+/;
846							my $user_regex = qr/[\w-]+(?:\.[\w-]+)*/;
847							my $user_id_regex = qr/$user_regex[@]$domain_regex/;
848							my $id_regex = qr/$user_id_regex\|[@]?$domain_regex/;
849							my $hostname_regex = qr/(?: id:$id_regex \| [\w-]+ )/x;
850							my $network_regex = qr/(?: [\w-]+ (?: \/ [\w-]+ )? )/x;
851
852							# Check for xxx:xxx or xxx:[xxx:xxx, ...]
853							# or interface:xxx.xxx
854							# or interface:xxx.xxx.xxx
855							# or interface:xxx.[xxx]
856							# or interface:r@v. ...
857							# or interface:....xxx/ppp...
858							# or interface:[xxx:xxx, ...].[xxx]
859							# or interface:[managed & xxx:xxx, ...].[xxx]
860							# or host:[managed & xxx:xxx, ...]
861							# or any:[ ip = n.n.n.n/len & xxx:xxx, ...]
862							# or network:xxx/ppp
863							# or host:id:user@domain.network
864							# or host:id:[@]domain.network
865							#
866							sub read_extended_name {
867
868	1259	100		1259	0	1422	if (check 'user') {
869
870							# Global variable for linking occurrences of 'user'.
871	322	50				609	$user_object->{active}
872							or syntax_err("Unexpected reference to 'user'");
873	322					296	$user_object->{refcount}++;
874	322					887	return [ 'user', $user_object ];
875							}
876	937	50				3482	$input =~ m/\G([\w-]+):/gc or syntax_err("Type expected");
877	937					1358	my $type = $1;
878	937					1026	my $interface = $type eq 'interface';
879	937					729	my $name;
880							my $ext;
881	937	100 100 100 50	40			3600	if ($input =~ m/ \G \[ /gcox) {
882	106	100 100	100 100			578	if (($interface \|\| $type eq 'host') && check('managed')) {
883	4					5	$ext = 1;
884	4					5	skip '&';
885							}
886							elsif ($type eq 'any' && check('ip')) {
887	44					61	skip '=';
888	44					70	$ext = read_ip_prefix_pair();
889	44					55	skip '&';
890							}
891	106					200	$name = [ read_union(']') ];
892							}
893							elsif ($type eq 'host') {
894	101	50				5057	$input =~ m/ \G ( $hostname_regex ) /gcox
895							or syntax_err("Name or ID-name expected");
896	101					415	$name = $1;
897							}
898							elsif ($type eq 'network') {
899	505	50				11239	$input =~ m/ \G ( $network_regex ) /gcox
900							or syntax_err("Name or bridged name expected");
901	505					1165	$name = $1;
902							}
903							elsif ($interface && $input =~ m/ \G ( [\w-]+ (?: \@ [\w-]+ ) ) /gcx
904							\|\| $input =~ m/ \G ( [\w-]+ ) /gcx)
905							{
906	225					336	$name = $1;
907							}
908							else {
909	0					0	syntax_err("Identifier or '[' expected");
910							}
911	937	100				1517	if ($interface) {
912	196	50				423	$input =~ m/ \G \. /gcox or syntax_err("Expected '.'");
913	196	100				294	if ($input =~ m/ \G \[ /gcox) {
914	31					44	my $selector = read_identifier;
915	31	50				109	$selector =~ /^(auto\|all)$/ or syntax_err("Expected [auto\|all]");
916	31					52	$ext = [ $selector, $ext ];
917	31					43	skip '\]';
918							}
919							else {
920	165	50				244	$ext and syntax_err("Keyword 'managed' not allowed");
921	165	50				5973	$input =~ m/ \G ( $network_regex ) /gcox
922							or syntax_err("Name or bridged name expected");
923	165					336	$ext = $1;
924
925							# ID of secondary interface.
926	165	100				341	if ($input =~ m/ \G \. /gcox) {
927	16					23	$ext .= '.' . read_identifier;
928							}
929							}
930							}
931	937	100				3059	return $ext ? [ $type, $name, $ext ] : [ $type, $name ];
932							}
933
934							# user@domain
935							sub read_user_id {
936	9			9	0	14	skip_space_and_comment;
937	9	50				377	if ($input =~ m/\G($user_id_regex)/gco) {
938	9					20	return $1;
939							}
940							else {
941	0					0	syntax_err("Id expected ('user\@domain' or 'user')");
942							}
943							}
944
945							# host:xxx or host:id:user@domain or host:id:[@]domain
946							sub check_hostname {
947	325			325	0	410	skip_space_and_comment;
948	325	100				700	if ($input =~ m/\G host:/gcx) {
949	201	50				13412	if ($input =~ m/\G($hostname_regex)/gco) {
950	201					608	return $1;
951							}
952							else {
953	0					0	syntax_err('Hostname expected');
954							}
955							}
956							else {
957	124					236	return;
958							}
959							}
960							}
961
962							sub read_complement {
963	1259	100		1259	0	1405	if (check '!') {
964	7					12	return [ '!', read_extended_name() ];
965							}
966							else {
967	1252					1681	return read_extended_name();
968							}
969							}
970
971							sub read_intersection {
972	1251			1251	0	1492	my @result = read_complement();
973	1251					1969	while (check '&') {
974	8					16	push @result, read_complement();
975							}
976	1251	100				1883	if (@result == 1) {
977	1243					1816	return $result[0];
978							}
979							else {
980	8					20	return [ '&', \@result ];
981							}
982							}
983
984							# Setup standard time units with different names and plural forms.
985							my %timeunits = (sec => 1, min => 60, hour => 3600, day => 86400,);
986							$timeunits{second} = $timeunits{sec};
987							$timeunits{minute} = $timeunits{min};
988							for my $key (keys %timeunits) {
989							$timeunits{"${key}s"} = $timeunits{$key};
990							}
991
992							# Read time value in different units, return seconds.
993							sub read_time_val {
994	40			40	0	49	my $int = read_int();
995	40					59	my $unit = read_identifier();
996	40	50				82	my $factor = $timeunits{$unit} or syntax_err("Invalid time unit");
997	40					78	return $int * $factor;
998							}
999
1000							sub add_description {
1001	3756			3756	0	3403	my ($obj) = @_;
1002	3756	100				4156	check 'description' or return;
1003	2					4	skip '=';
1004
1005							# Read up to end of line, but ignore ';' at EOL.
1006							# We must use '$' here to match EOL,
1007							# otherwise $line would be out of sync.
1008	2					22	$input =~ m/\G[ \t](.?)[ \t];?[ \t]$/gcm;
1009	2	50				4	if (store_description()) {
1010	0					0	$obj->{description} = $1;
1011							}
1012	2					2	return;
1013							}
1014
1015							# Check if one of the keywords 'permit' or 'deny' is available.
1016							sub check_permit_deny {
1017	311			311	0	379	skip_space_and_comment();
1018	311	50				798	if ($input =~ m/\G(permit\|deny)/gc) {
1019	311					972	return $1;
1020							}
1021							else {
1022	0					0	return;
1023							}
1024							}
1025
1026							sub check_nat_name {
1027	136			136	0	160	skip_space_and_comment;
1028	136	50				420	if ($input =~ m/\G nat:([\w-]+)/gcx) {
1029	136					367	return $1;
1030							}
1031							else {
1032	0					0	return;
1033							}
1034							}
1035							sub split_typed_name {
1036	181			181	0	212	my ($name) = @_;
1037
1038							# Split at first colon; the name may contain further colons.
1039	181					595	return split /[:]/, $name, 2;
1040							}
1041
1042							sub check_flag {
1043	18003			18003	0	14602	my $token = shift;
1044	18003	100				18570	if (check $token) {
1045	237					375	skip(';');
1046	237					468	return 1;
1047							}
1048							else {
1049	17766					33187	return;
1050							}
1051							}
1052
1053							sub check_assign {
1054	14291			14291	0	13344	my ($token, $fun) = @_;
1055	14291	100				14942	if (check($token)) {
1056	2877					3660	skip '=';
1057	2877	100				4352	if (wantarray) {
1058	1155					1402	my @val = &$fun;
1059	1155					1403	skip(';');
1060	1155					3079	return @val;
1061							}
1062							else {
1063	1722					1997	my $val = &$fun;
1064	1722					2354	skip(';');
1065	1722					4110	return $val;
1066							}
1067							}
1068	11414					27539	return;
1069							}
1070
1071							sub read_list {
1072	2652			2652	0	2350	my ($fun) = @_;
1073	2652					2063	my @vals;
1074	2652					2037	while (1) {
1075	2956					3446	push @vals, &$fun;
1076	2956	100				3793	last if check(';');
1077	331					445	my $comma_seen = check ',';
1078
1079							# Allow trailing comma.
1080	331	100				466	last if check(';');
1081
1082	304	50				510	$comma_seen or syntax_err("Comma expected in list of values");
1083							}
1084	2652					7212	return @vals;
1085							}
1086
1087							sub read_list_or_null {
1088	11			11	0	18	my ($fun) = @_;
1089	11	50				14	return () if check(';');
1090	11					21	return read_list($fun);
1091							}
1092
1093							sub read_assign_list {
1094	311			311	0	695	my ($token, $fun) = @_;
1095	311					377	skip $token;
1096	311					441	skip '=';
1097	311					475	return read_list($fun);
1098							}
1099
1100							sub check_assign_list {
1101	11622			11622	0	10987	my ($token, $fun) = @_;
1102	11622	100				12372	if (check $token) {
1103	2027					2536	skip '=';
1104	2027					3033	return &read_list($fun);
1105							}
1106	9595					24169	return ();
1107							}
1108
1109							sub check_assign_pair {
1110	104			104	0	121	my ($token, $delimiter, $fun) = @_;
1111	104	100				127	if (check $token) {
1112	22					32	skip '=';
1113	22					32	my $v1 = &$fun;
1114	22					31	skip $delimiter;
1115	22					26	my $v2 = &$fun;
1116	22					33	skip(';');
1117	22					60	return $v1, $v2;
1118							}
1119	82					204	return ();
1120							}
1121
1122							####################################################################
1123							# Creation of typed structures
1124							# Currently we don't use OO features;
1125							# We use 'bless' only to give each structure a distinct type.
1126							####################################################################
1127
1128							# A hash, describing, which parts are read fom JSON.
1129							# Possible keys:
1130							# - watchers
1131							my $from_json;
1132
1133							# Create a new structure of given type;
1134							# initialize it with key / value pairs.
1135							sub new {
1136	8253			8253	0	13026	my ($type, @pairs) = @_;
1137	8253					13802	my $self = {@pairs};
1138	8253					24129	return bless $self, $type;
1139							}
1140
1141							sub add_attribute {
1142	6180			6180	0	6494	my ($obj, $key, $value) = @_;
1143	6180	50				10145	defined $obj->{$key} and error_atline("Duplicate attribute '$key'");
1144	6180					7232	$obj->{$key} = $value;
1145	6180					8365	return;
1146							}
1147
1148							our %hosts;
1149
1150							sub check_radius_attributes {
1151	1889			1889	0	1857	my $result = {};
1152	1889	100				2257	check 'radius_attributes' or return;
1153	23					31	skip '=';
1154	23					32	skip '\{';
1155	23					24	while (1) {
1156	55	100				61	last if check '\}';
1157	32					44	my $key = read_identifier();
1158	32	50				45	my $val = check('=') ? read_string : undef;
1159	32					44	skip ';';
1160	32					44	add_attribute($result, $key => $val);
1161							}
1162	23					47	return $result;
1163							}
1164
1165							sub check_routing {
1166	1696	100		1696	0	2316	my $protocol = check_assign('routing', \&read_identifier) or return;
1167	141	50				352	my $routing = $routing_info{$protocol}
1168							or error_atline('Unknown routing protocol');
1169	141					253	return $routing;
1170							}
1171
1172							sub check_managed {
1173	2716	100		2716	0	2996	check('managed') or return;
1174	473					458	my $managed;
1175	473	100 50				589	if (check ';') {
1176	416					455	$managed = 'standard';
1177							}
1178							elsif (check '=') {
1179	57					88	my $value = read_identifier;
1180	57	50				188	if ($value =~ /^(?:secondary\|standard\|full\|primary\|
1181							local\|local_secondary\|routing_only)$/x)
1182							{
1183	57					62	$managed = $value;
1184							}
1185							else {
1186	0					0	error_atline("Expected value:",
1187							" secondary\|standard\|full\|primary",
1188							"\|local\|local_secondary\|routing_only");
1189							}
1190	57					69	check ';';
1191							}
1192							else {
1193	0					0	syntax_err("Expected ';' or '='");
1194							}
1195	473					888	return $managed;
1196							}
1197
1198							sub check_model {
1199	2217	100		2217	0	3076	my ($model, @attributes) = check_assign_list('model', \&read_name)
1200							or return;
1201	485					772	my $info = $router_info{$model};
1202	485	100				934	if (not $info) {
1203	1					2	error_atline("Unknown router model");
1204
1205							# Prevent further errors.
1206	1					4	return { name => $model };;
1207							}
1208	484		100			1027	my $extension_info = $info->{extension} \|\| {};
1209
1210	125					147	my @ext_list = map {
1211	484					568	my $ext = $extension_info->{$_};
1212	125	100				185	$ext or error_atline("Unknown extension $_");
1213	125	100				453	$ext ? %$ext : ();
1214							} @attributes;
1215	484	100				997	if (@ext_list) {
1216	123					1051	$info = { %$info, @ext_list };
1217	123					272	delete $info->{extension};
1218	123					322	$info->{name} = join(', ', $model, sort @attributes);
1219							}
1220	484					1049	return $info;
1221							}
1222
1223							my @managed_routers;
1224							my @router_fragments;
1225
1226							# Managed host is stored internally as an interface.
1227							# The interface gets an artificial router.
1228							# Both, router and interface get name "host:xx".
1229							sub host_as_interface {
1230	20			20	0	22	my ($host) = @_;
1231	20					22	my $name = $host->{name};
1232	20					25	my $model = delete $host->{model};
1233	20					24	my $hw_name = delete $host->{hardware};
1234	20	100 50				48	if (!$model) {
1235	1					3	err_msg("Missing 'model' for managed $host->{name}");
1236
1237							# Prevent further errors.
1238	1					2	$model = $host->{model} = { name => 'unknown' };
1239							}
1240							elsif (!$model->{can_managed_host}) {
1241	0					0	err_msg("Must not use model $model->{name} at managed $name");
1242							}
1243	20	50				33	if (!$hw_name) {
1244	0					0	err_msg("Missing 'hardware' for $name");
1245							}
1246
1247							# Use device_name with "host:.." prefix to prevent name clash with
1248							# real routers.
1249	20	100				27	my $device_name =
1250							$host->{server_name} ? "host:$host->{server_name}" : $name;
1251	20					27	my $router = new('Router', name => $name, device_name => $device_name);
1252	20					31	$router->{managed} = delete $host->{managed};
1253	20					21	$router->{model} = $model;
1254	20					35	my $interface = new('Interface', %$host);
1255	20					22	$interface->{router} = $router;
1256	20					43	my $hardware = { name => $hw_name, interfaces => [ $interface ] };
1257	20					22	$interface->{hardware} = $hardware;
1258	20					23	$interface->{routing} = $routing_info{manual};
1259	20					19	$interface->{is_managed_host} = 1;
1260	20					26	$router->{interfaces} = [ $interface ];
1261	20					23	$router->{hardware} = [ $hardware ];
1262
1263							# Don't add to %routers
1264							# - Name lookup isn't needed.
1265							# - Linking with network isn't needed.
1266	20					20	push @managed_routers, $router;
1267	20					81	return $interface;
1268							}
1269
1270							sub read_host {
1271	201			201	0	246	my ($name, $network_name) = @_;
1272	201					265	my $host = new('Host');
1273	201	50				343	$host->{private} = $private if $private;
1274	201	100				502	if (my ($id) = ($name =~ /^host:id:(.*)$/)) {
1275
1276							# Make ID unique by appending name of enclosing network.
1277	26					44	$name = "$name.$network_name";
1278	26					55	$host->{id} = $id;
1279							}
1280	201					312	$host->{name} = $name;
1281	201					261	skip '=';
1282	201					293	skip '\{';
1283	201					312	add_description($host);
1284	201					208	while (1) {
1285	483	100				585	last if check '\}';
1286	282	100 100 100 100 100 100 100 100 50				511	if (my $ip = check_assign 'ip', \&read_ip) {
1287	178					1345	add_attribute($host, ip => $ip);
1288							}
1289							elsif (my ($ip1, $ip2) = check_assign_pair('range', '-', \&read_ip)) {
1290	22	50				36	$ip1 <= $ip2 or error_atline("Invalid IP range");
1291	22					47	add_attribute($host, range => [ $ip1, $ip2 ]);
1292							}
1293
1294							# Currently, only simple 'managed' attribute,
1295							# because 'secondary' and 'local' isn't supported by Linux.
1296							elsif (my $managed = check_managed()) {
1297	20	100				33	$managed eq 'standard'
1298							or error_atline("Only 'managed=standard' is supported");
1299	20					28	add_attribute($host, managed => $managed);
1300							}
1301							elsif (my $model = check_model()) {
1302	20	50				30	$host->{model} and error_atline("Duplicate attribute 'model'");
1303	20					25	add_attribute($host, model => $model);
1304							}
1305							elsif (my $hardware = check_assign('hardware', \&read_name)) {
1306	21					30	add_attribute($host, hardware => $hardware);
1307							}
1308							elsif (my $server_name = check_assign('server_name', \&read_name)) {
1309	2					3	add_attribute($host, server_name => $server_name);
1310							}
1311							elsif (my $owner = check_assign 'owner', \&read_identifier) {
1312	7					12	add_attribute($host, owner => $owner);
1313							}
1314							elsif (my $radius_attributes = check_radius_attributes) {
1315	9					15	add_attribute($host, radius_attributes => $radius_attributes);
1316							}
1317							elsif (my $pair = check_typed_name) {
1318	3					5	my ($type, $name) = @$pair;
1319	3	50				6	if ($type eq 'nat') {
1320	3					5	skip '=';
1321	3					62	skip '\{';
1322	3					6	skip 'ip';
1323	3					6	skip '=';
1324	3					5	my $nat_ip = read_ip;
1325	3					7	skip ';';
1326	3					6	skip '\}';
1327	3	50				10	$host->{nat}->{$name}
1328							and error_atline("Duplicate NAT definition");
1329	3					9	$host->{nat}->{$name} = $nat_ip;
1330							}
1331							else {
1332	0					0	syntax_err("Expected NAT definition");
1333							}
1334							}
1335							else {
1336	0					0	syntax_err("Unexpected attribute");
1337							}
1338							}
1339	201	100	75			934	$host->{ip} xor $host->{range}
1340							or error_atline("Exactly one of attributes 'ip' and 'range' is needed");
1341
1342	201	100				344	if ($host->{managed}) {
1343	20					71	my %ok = ( name => 1, ip => 1, nat => 1, file => 1, private => 1,
1344							managed => 1, model => 1, hardware => 1, server_name => 1);
1345	20					76	for my $key (sort keys %$host) {
1346	101	100				160	next if $ok{$key};
1347	1					5	error_atline("Managed $host->{name} must not have attribute '$key'");
1348							}
1349	20		100			45	$host->{ip} \|\|= 'short';
1350	20					28	return host_as_interface($host);
1351							}
1352	181	100				284	if ($host->{id}) {
1353	26		100			65	$host->{radius_attributes} \|\|= {};
1354							}
1355							else {
1356	155	50				278	$host->{radius_attributes}
1357							and error_atline("Attribute 'radius_attributes' is not allowed",
1358							" for $name");
1359							}
1360	181	100				303	if ($host->{nat}) {
1361	2	50				4	if ($host->{range}) {
1362
1363							# Before changing this,
1364							# - look at print_pix_static,
1365							# - add consistency tests in convert_hosts.
1366	0					0	error_atline("No NAT supported for host with 'range'");
1367							}
1368							}
1369	181					242	return $host;
1370							}
1371
1372							sub read_nat {
1373	136			136	0	151	my $name = shift;
1374
1375							# Currently this needs not to be blessed.
1376	136					214	my $nat = { name => $name };
1377	136					435	(my $nat_tag = $name) =~ s/^nat://;
1378	136					211	skip '=';
1379	136					192	skip '\{';
1380	136					129	while (1) {
1381	312	100				382	last if check '\}';
1382	176	100 100 100 100 50				293	if (my ($ip, $mask) = check_assign 'ip', \&read_ip_prefix) {
1383	90					134	add_attribute($nat, ip => $ip);
1384	90					109	add_attribute($nat, mask => $mask);
1385							}
1386							elsif (check_flag 'hidden') {
1387	37					60	$nat->{hidden} = 1;
1388							}
1389							elsif (check_flag 'identity') {
1390	9					15	$nat->{identity} = 1;
1391							}
1392							elsif (check_flag 'dynamic') {
1393
1394							# $nat_tag is used later to look up static translation
1395							# of hosts inside a dynamically translated network.
1396	38					79	$nat->{dynamic} = $nat_tag;
1397							}
1398							elsif (my $pair = check_assign 'subnet_of', \&read_typed_name) {
1399	2					3	add_attribute($nat, subnet_of => $pair);
1400							}
1401							else {
1402	0					0	syntax_err("Expected some valid NAT attribute");
1403							}
1404							}
1405	136	100 100				305	if ($nat->{hidden}) {
1406	37					78	for my $key (keys %$nat) {
1407	74 148	50				69 278	next if grep { $key eq $_ } qw( name hidden );
1408	0					0	error_atline("Hidden NAT must not use attribute $key");
1409							}
1410
1411							# This simplifies error checks for overlapping addresses.
1412	37					60	$nat->{dynamic} = $nat_tag;
1413							}
1414							elsif ($nat->{identity}) {
1415	9					21	for my $key (keys %$nat) {
1416	18 36	50				21 69	next if grep { $key eq $_ } qw( name identity );
1417	0					0	error_atline("Identity NAT must not use attribute $key");
1418							}
1419	9					17	$nat->{dynamic} = $nat_tag;
1420							}
1421							else {
1422	90	50				170	defined($nat->{ip}) or error_atline('Missing IP address');
1423							}
1424	136					168	return $nat;
1425							}
1426
1427							our %networks;
1428
1429							sub read_network {
1430	1053			1053	0	988	my $name = shift;
1431
1432							# Network name without prefix "network:" is needed to build
1433							# name of ID-hosts.
1434	1053					3212	(my $net_name = $name) =~ s/^network://;
1435	1053					1640	my $network = new('Network', name => $name);
1436	1053	100				1618	$network->{private} = $private if $private;
1437	1053	100				1980	if ($net_name =~ m,^(.*)/,) {
1438	14					29	$network->{bridged} = $1;
1439							}
1440	1053					1313	skip '=';
1441	1053					1484	skip '\{';
1442	1053					1623	add_description($network);
1443	1053					956	while (1) {
1444	2532	100				2970	last if check '\}';
1445	1479	100 100 100 100 100 100 100 100 50				2629	if (my ($ip, $mask) = check_assign 'ip', \&read_ip_prefix) {
1446	1042					1441	add_attribute($network, ip => $ip);
1447	1042					1160	add_attribute($network, mask => $mask);
1448							}
1449							elsif (check_flag 'unnumbered') {
1450	11	50				23	defined $network->{ip} and error_atline("Duplicate IP address");
1451	11					21	$network->{ip} = 'unnumbered';
1452							}
1453							elsif (check_flag 'has_subnets') {
1454
1455							# Duplicate use of this flag doesn't matter.
1456	36					66	$network->{has_subnets} = 1;
1457							}
1458							elsif (check_flag 'crosslink') {
1459
1460							# Duplicate use of this flag doesn't matter.
1461	10					18	$network->{crosslink} = 1;
1462							}
1463							elsif (my $pair = check_assign 'subnet_of', \&read_typed_name) {
1464	30					54	add_attribute($network, subnet_of => $pair);
1465							}
1466							elsif (my $owner = check_assign 'owner', \&read_identifier) {
1467	19					35	add_attribute($network, owner => $owner);
1468							}
1469							elsif (my $radius_attributes = check_radius_attributes) {
1470	6					10	add_attribute($network, radius_attributes => $radius_attributes);
1471							}
1472							elsif (my $host_name = check_hostname()) {
1473	201					497	my $host = read_host("host:$host_name", $net_name);
1474	201					274	$host->{network} = $network;
1475	201	100 50				301	if (is_host($host)) {
1476	181 181					158 310	push @{ $network->{hosts} }, $host;
1477	181					300	$host_name = (split_typed_name($host->{name}))[1];
1478							}
1479
1480							# Managed host is stored as interface internally.
1481							elsif (is_interface($host)) {
1482	20 20					18 30	push @{ $network->{interfaces} }, $host;
1483	20					32	check_interface_ip($host, $network);
1484
1485							# For use in expand_group.
1486	20 20					13 33	push @{ $network->{managed_hosts} }, $host;
1487							}
1488							else {
1489	0					0	internal_err;
1490							}
1491	201	50				488	if (my $other = $hosts{$host_name}) {
1492	0					0	my $where = $current_file;
1493	0					0	my $other_net = $other->{network};
1494	0	0				0	if ($other_net ne $network) {
1495	0					0	$where .= " $other_net->{file}";
1496							}
1497	0					0	err_msg("Duplicate definition of host:$host_name in $where");
1498							}
1499	201					1118	$hosts{$host_name} = $host;
1500							}
1501							elsif (my $nat_tag = check_nat_name()) {
1502	124					258	my $nat = read_nat("nat:$nat_tag");
1503	124	50	67			320	($network->{nat} && $network->{nat}->{$nat_tag})
1504							and error_atline("Duplicate NAT definition");
1505
1506	124					282	$nat->{name} .= "($name)";
1507	124					336	$network->{nat}->{$nat_tag} = $nat;
1508							}
1509							else {
1510	0					0	syntax_err("Expected some valid attribute");
1511							}
1512							}
1513
1514							# Network needs at least IP and mask to be defined.
1515	1053					1422	my $ip = $network->{ip};
1516
1517							# Use 'defined' here because IP may have value '0'.
1518	1053	50				1565	defined $ip or syntax_err("Missing network IP");
1519
1520	1053	100 100				2228	if ($ip eq 'unnumbered') {
1521	11					31	my %ok = (ip => 1, name => 1, crosslink => 1, private => 1);
1522
1523							# Unnumbered network must not have any other attributes.
1524	11					25	for my $key (keys %$network) {
1525	22	50				50	next if $ok{$key};
1526	0	0 0				0	error_atline("Unnumbered $network->{name} must not have ",
1527							($key eq 'hosts') ? "host definition"
1528							: ($key eq 'nat') ? "nat definition"
1529							: "attribute '$key'");
1530							}
1531							}
1532							elsif ($network->{bridged}) {
1533	14					46	my %ok = (ip => 1, mask => 1, bridged => 1, name => 1, private => 1,
1534							nat => 1, owner => 1, crosslink => 1);
1535
1536							# Bridged network must not have any other attributes.
1537	14					30	for my $key (keys %$network) {
1538	57	50				98	next if $ok{$key};
1539	0	0				0	error_atline(
1540							"Bridged $network->{name} must not have ",
1541							($key eq 'hosts') ? "host definition (not implemented)"
1542							: "attribute '$key'");
1543							}
1544	14	50				37	if (my $hash = $network->{nat}) {
1545	0					0	for my $nat_tag (sort keys %$hash) {
1546	0	0				0	$hash->{$nat_tag}->{identity} and next;
1547	0					0	delete $hash->{$nat_tag};
1548	0					0	err_msg("Only identity NAT allowed for bridged $network->{name}");
1549	0					0	last;
1550							}
1551							}
1552							}
1553							else {
1554	1028					1041	my $mask = $network->{mask};
1555	1028 1028					837 2015	for my $host (@{ $network->{hosts} }) {
1556
1557							# Check compatibility of host IP and network IP/mask.
1558	181	100 50				323	if (my $host_ip = $host->{ip}) {
1559	160	50				248	if (not(match_ip($host_ip, $ip, $mask))) {
1560	0					0	error_atline("$host->{name}'s IP doesn't match".
1561							" network IP/mask");
1562							}
1563							}
1564							elsif ($host->{range}) {
1565	21 21					19 28	my ($ip1, $ip2) = @{ $host->{range} };
1566	21	50	33			33	if (
1567							not( match_ip($ip1, $ip, $mask)
1568							and match_ip($ip2, $ip, $mask))
1569							)
1570							{
1571	0					0	error_atline("$host->{name}'s IP range doesn't match",
1572							" network IP/mask");
1573							}
1574							}
1575							else {
1576	0					0	internal_err();
1577							}
1578
1579							# Compatibility of host and network NAT will be checked later,
1580							# after inherited NAT definitions have been processed.
1581							}
1582	1028 1028	100	100			878 2455	if (@{ $network->{hosts} } and $network->{crosslink}) {
1583	1					2	error_atline("Crosslink network must not have host definitions");
1584							}
1585	1028	100				1618	if ($network->{nat}) {
1586
1587							# Check NAT definitions.
1588	95 95					86 198	for my $nat (values %{ $network->{nat} }) {
1589	124	100				251	next if $nat->{dynamic};
1590	52	50				123	$nat->{mask} == $mask
1591							or error_atline("Mask for non dynamic $nat->{name}",
1592							" must be equal to network mask");
1593							}
1594							}
1595
1596							# Check and mark networks with ID-hosts.
1597	1028 181 1028	100				807 364 1673	if (my $id_hosts_count = grep { $_->{id} } @{ $network->{hosts} }) {
1598
1599							# If one host has ID, all hosts must have ID.
1600	13 13	50				13 24	@{ $network->{hosts} } == $id_hosts_count
1601							or error_atline("All hosts must have ID in $name");
1602
1603							# Mark network.
1604	13					17	$network->{has_id_hosts} = 1;
1605	13		100			32	$network->{radius_attributes} \|\|= {};
1606							}
1607							else {
1608	1015	50				1860	$network->{radius_attributes}
1609							and error_atline("Attribute 'radius_attributes' is",
1610							" not allowed for $name");
1611							}
1612							}
1613	1053					1330	return $network;
1614							}
1615
1616							our %interfaces;
1617							my @virtual_interfaces;
1618							my $global_active_pathrestriction = new(
1619							'Pathrestriction',
1620							name => 'global_pathrestriction',
1621							active_path => 1
1622							);
1623
1624							# Tunnel networks which are already attached to tunnel interfaces
1625							# at spoke devices. Key is crypto name, not crypto object.
1626							my %crypto2spokes;
1627
1628							# Real interfaces at crypto hub, where tunnels are attached.
1629							# Key is crypto name, not crypto object.
1630							my %crypto2hubs;
1631
1632							sub read_interface {
1633	1485			1485	0	1367	my ($name) = @_;
1634	1485					1841	my $interface = new('Interface', name => $name);
1635
1636							# Short form of interface definition.
1637	1485	100				1815	if (not check '=') {
1638	188					253	skip ';';
1639	188					284	$interface->{ip} = 'short';
1640	188					314	return $interface;
1641							}
1642
1643	1297					1503	my @secondary_interfaces = ();
1644	1297					985	my $virtual;
1645	1297					1594	skip '\{';
1646	1297					1907	add_description($interface);
1647	1297					1162	while (1) {
1648	3889	100				4508	last if check '\}';
1649	2592	100 100 100 100 100 100 100 100 100 100 100 50 100 100 100 100 100 100 100 100 50				4154	if (my @ip = check_assign_list 'ip', \&read_ip) {
1650	1226					1788	add_attribute($interface, ip => shift(@ip));
1651
1652							# Build interface objects for secondary IP addresses.
1653							# These objects are named interface:router.name.2, ...
1654	1226					1057	my $counter = 2;
1655	1226					2182	for my $ip (@ip) {
1656	5					17	push @secondary_interfaces,
1657							new('Interface', name => "$name.$counter", ip => $ip);
1658	5					13	$counter++;
1659							}
1660							}
1661							elsif (check_flag 'unnumbered') {
1662	13					20	add_attribute($interface, ip => 'unnumbered');
1663							}
1664							elsif (check_flag 'negotiated') {
1665	3					5	add_attribute($interface, ip => 'negotiated');
1666							}
1667							elsif (check_flag 'loopback') {
1668	27					54	$interface->{loopback} = 1;
1669							}
1670							elsif (check_flag 'vip') {
1671	5					10	$interface->{vip} = 1;
1672							}
1673							elsif (check_flag 'no_in_acl') {
1674	7					14	$interface->{no_in_acl} = 1;
1675							}
1676							elsif (check_flag 'dhcp_server') {
1677	1					3	$interface->{dhcp_server} = 1;
1678							}
1679
1680							# Needed for the implicitly defined network of 'loopback'.
1681							elsif (my $pair = check_assign 'subnet_of', \&read_typed_name) {
1682	4					6	add_attribute($interface, subnet_of => $pair);
1683							}
1684							elsif (my @pairs = check_assign_list 'hub', \&read_typed_name) {
1685	18					22	for my $pair (@pairs) {
1686	21					26	my ($type, $name2) = @$pair;
1687	21	50				37	$type eq 'crypto' or error_atline("Expected type 'crypto'");
1688	21 21					21 101	push @{ $interface->{hub} }, "$type:$name2";
1689							}
1690							}
1691							elsif ($pair = check_assign 'spoke', \&read_typed_name) {
1692	25					34	my ($type, $name2) = @$pair;
1693	25	50				43	$type eq 'crypto' or error_atline("Expected type crypto");
1694	25					64	add_attribute($interface, spoke => "$type:$name2");
1695							}
1696							elsif (my $id = check_assign 'id', \&read_user_id) {
1697	9					13	add_attribute($interface, id => $id);
1698							}
1699							elsif (defined(my $level = check_assign 'security_level', \&read_int)) {
1700	0	0				0	$level > 100
1701							and error_atline("Maximum value for attribute security_level",
1702							" is 100");
1703	0					0	add_attribute($interface, security_level => $level);
1704							}
1705							elsif ($pair = check_typed_name) {
1706	11					17	my ($type, $name2) = @$pair;
1707	11	100 50				26	if ($type eq 'nat') {
1708	2					4	skip '=';
1709	2					4	skip '\{';
1710	2					3	skip 'ip';
1711	2					4	skip '=';
1712	2					4	my $nat_ip = read_ip;
1713	2					3	skip ';';
1714	2					5	skip '\}';
1715	2	50				6	$interface->{nat}->{$name2}
1716							and error_atline("Duplicate NAT definition");
1717	2					7	$interface->{nat}->{$name2} = $nat_ip;
1718							}
1719							elsif ($type eq 'secondary') {
1720
1721							# Build new interface for secondary IP addresses.
1722	9					26	my $secondary = new('Interface', name => "$name.$name2");
1723	9					15	skip '=';
1724	9					12	skip '\{';
1725	9					10	while (1) {
1726	18	100				23	last if check '\}';
1727	9	50				24	if (my $ip = check_assign 'ip', \&read_ip) {
1728	9					13	add_attribute($secondary, ip => $ip);
1729							}
1730							else {
1731	0					0	syntax_err("Expected attribute IP");
1732							}
1733							}
1734	9	50				19	if ($secondary->{ip}) {
1735	9					26	push @secondary_interfaces, $secondary;
1736							}
1737							else {
1738	0					0	error_atline("Missing IP address");
1739							}
1740							}
1741							else {
1742	0					0	syntax_err("Expected nat or secondary interface definition");
1743							}
1744							}
1745							elsif (check 'virtual') {
1746	72	50				130	$virtual and error_atline("Duplicate virtual interface");
1747
1748							# Read attributes of redundancy protocol (VRRP/HSRP).
1749	72					190	$virtual = new(
1750							'Interface',
1751							name => "$name.virtual",
1752							redundant => 1
1753							);
1754	72					102	skip '=';
1755	72					103	skip '\{';
1756	72					68	while (1) {
1757	158	100				183	last if check '\}';
1758	86	100 50 0				135	if (my $ip = check_assign 'ip', \&read_ip) {
1759	72					100	add_attribute($virtual, ip => $ip);
1760							}
1761							elsif (my $type = check_assign 'type', \&read_identifier) {
1762	14	50				28	$xxrp_info{$type}
1763							or error_atline("unknown redundancy protocol");
1764	14					18	add_attribute($virtual, redundancy_type => $type);
1765							}
1766							elsif (my $id = check_assign 'id', \&read_identifier) {
1767	0	0				0	$id =~ /^\d+$/
1768							or error_atline("Redundancy ID must be numeric");
1769	0	0				0	$id < 256 or error_atline("Redundancy ID must be < 256");
1770	0					0	add_attribute($virtual, redundancy_id => $id);
1771							}
1772							else {
1773	0					0	syntax_err("Expected valid attribute for virtual IP");
1774							}
1775							}
1776	72	50				149	$virtual->{ip} or error_atline("Missing virtual IP");
1777	72	50	33			203	($virtual->{redundancy_id} && !$virtual->{redundancy_type}) and
1778							syntax_err("Redundancy ID is given without redundancy protocol");
1779							}
1780							elsif (my @tags = check_assign_list 'bind_nat', \&read_identifier) {
1781	108	50				201	$interface->{bind_nat} and error_atline("Duplicate NAT binding");
1782	108					193	$interface->{bind_nat} = [ unique sort @tags ];
1783							}
1784							elsif (my $hardware = check_assign 'hardware', \&read_name) {
1785	1044					1411	add_attribute($interface, hardware => $hardware);
1786							}
1787							elsif (my $owner = check_assign 'owner', \&read_identifier) {
1788	3					4	add_attribute($interface, owner => $owner);
1789							}
1790							elsif (my $routing = check_routing()) {
1791	8					13	add_attribute($interface, routing => $routing);
1792							}
1793							elsif (@pairs = check_assign_list 'reroute_permit', \&read_typed_name) {
1794	2 2	50 50				3 13	if (grep { $_->[0] ne 'network' \|\| ref $_->[1] } @pairs) {
1795	0					0	error_atline "Must only use network names in 'reroute_permit'";
1796	0					0	@pairs = ();
1797							}
1798	2					4	add_attribute($interface, reroute_permit => \@pairs);
1799							}
1800							elsif (check_flag 'disabled') {
1801	3					9	$interface->{disabled} = 1;
1802							}
1803							elsif (check_flag 'no_check') {
1804	3					9	$interface->{no_check} = 1;
1805							}
1806							else {
1807	0					0	syntax_err('Expected some valid attribute');
1808							}
1809							}
1810
1811							# Interface at bridged network
1812							# - without IP is interface of bridge,
1813							# - with IP is interface of router.
1814	1297	100				2509	if ($name =~ m,/,) {
1815	24		100			62	$interface->{ip} \|\|= 'bridged';
1816							}
1817
1818							# Swap virtual interface and main interface
1819							# or take virtual interface as main interface if no main IP available.
1820							# Subsequent code becomes simpler if virtual interface is main interface.
1821	1297	100				1609	if ($virtual) {
1822	72	100				136	if (my $ip = $interface->{ip}) {
1823	64	50				160	if ($ip =~ /^(unnumbered\|negotiated\|short\|bridged)$/) {
1824	0					0	error_atline("No virtual IP supported for $ip interface");
1825							}
1826
1827							# Move main IP to secondary.
1828	64					98	my $secondary =
1829							new('Interface', name => $interface->{name}, ip => $ip);
1830	64					57	push @secondary_interfaces, $secondary;
1831
1832							# But we need the original main interface
1833							# when handling auto interfaces.
1834	64					84	$interface->{orig_main} = $secondary;
1835							}
1836	72 72					169 103	@{$interface}{qw(name ip redundant redundancy_type redundancy_id)} =
1837	72					69	@{$virtual}{qw(name ip redundant redundancy_type redundancy_id)};
1838	72					98	push @virtual_interfaces, $interface;
1839							}
1840							else {
1841	1225		100			2218	$interface->{ip} \|\|= 'short';
1842							}
1843	1297	100				2035	if ($interface->{nat}) {
1844	2	50				6	if ($interface->{ip} =~ /^(unnumbered\|negotiated\|short\|bridged)$/) {
1845	0					0	error_atline("No NAT supported for $interface->{ip} interface");
1846							}
1847							}
1848	1297	100				1898	if ($interface->{vip}) {
1849	5					9	$interface->{loopback} = 1;
1850	5	50				10	$interface->{hardware} and
1851							error_atline("'vip' interface must not have attribute 'hardware'");
1852	5					5	$interface->{hardware} = 'VIP';
1853							}
1854	1297	50	67			2214	if ($interface->{owner} && !$interface->{vip}) {
1855	0					0	error_atline("Must use attribute 'owner' only at 'vip' interface");
1856	0					0	delete $interface->{owner};
1857							}
1858	1297	100 50				2549	if ($interface->{loopback}) {
1859	32					128	my %copy = %$interface;
1860
1861							# Only these attributes are valid.
1862							delete @copy{
1863	32					104	qw(name ip nat bind_nat hardware loopback subnet_of
1864							owner redundant redundancy_type redundancy_id vip)
1865							};
1866	32	50				58	if (keys %copy) {
1867	0 0					0 0	my $attr = join ", ", map { "'$_'" } keys %copy;
1868	0	0				0	my $type = $interface->{vip} ? "'vip'" : 'loopback';
1869	0					0	error_atline("Invalid attributes $attr for $type interface");
1870							}
1871	32	50				104	if ($interface->{ip} =~ /^(unnumbered\|negotiated\|short\|bridged)$/) {
1872	0	0				0	my $type = $interface->{vip} ? "'vip'" : 'Loopback';
1873	0					0	error_atline("$type interface must not be $interface->{ip}");
1874	0					0	$interface->{disabled} = 1;
1875							}
1876							}
1877							elsif ($interface->{subnet_of}) {
1878	0					0	error_atline("Attribute 'subnet_of' is only valid",
1879							" for loopback interface");
1880							}
1881	1297	100				2332	if ($interface->{ip} eq 'bridged') {
1882	14					33	my %ok = (ip => 1, hardware => 1, name => 1, bind_nat => 1);
1883	14 42	50				29 87	if (my @extra = grep { !$ok{$_} } keys %$interface) {
1884	0 0					0 0	my $attr = join ", ", map { "'$_'" } @extra;
1885	0					0	error_atline("Invalid attributes $attr for bridged interface");
1886							}
1887							}
1888	1297	100				1683	if (my $crypto = $interface->{spoke}) {
1889							@secondary_interfaces
1890	25	50				41	and error_atline("Interface with attribute 'spoke'",
1891							" must not have secondary interfaces");
1892	25	50				37	$interface->{hub}
1893							and error_atline("Interface with attribute 'spoke'",
1894							" must not have attribute 'hub'");
1895							}
1896							else {
1897	1272	50				1937	$interface->{id}
1898							and error_atline("Attribute 'id' is only valid for 'spoke' interface");
1899							}
1900	1297	100				1897	if (my $crypto_list = $interface->{hub}) {
1901	18	50				44	if ($interface->{ip} =~ /^(unnumbered\|negotiated\|short\|bridged)$/) {
1902	0					0	error_atline("Crypto hub must not be $interface->{ip} interface");
1903							}
1904	18					27	for my $crypto (@$crypto_list) {
1905	21 21					17 62	push @{ $crypto2hubs{$crypto} }, $interface;
1906							}
1907							}
1908	1297	100				1945	if (@secondary_interfaces) {
1909	74	50				173	if ($interface->{ip} =~ /^(unnumbered\|negotiated\|short\|bridged)$/) {
1910	0					0	error_atline("\u$interface->{ip} interface must not have",
1911							" secondary IP address");
1912	0					0	@secondary_interfaces = ();
1913							}
1914							}
1915	1297					1664	for my $secondary (@secondary_interfaces) {
1916	78					91	$secondary->{main_interface} = $interface;
1917	78					77	for my $key (qw(hardware bind_nat routing disabled)) {
1918	312	100				679	$secondary->{$key} = $interface->{$key} if $interface->{$key};
1919							}
1920							}
1921	1297					2327	return $interface, @secondary_interfaces;
1922							}
1923
1924							# PIX firewalls have a security level associated with each interface.
1925							# Use attribute 'security_level' or
1926							# try to derive the level from the interface name.
1927							sub set_pix_interface_level {
1928	258			258	0	264	my ($router) = @_;
1929	258 258					208 373	for my $hardware (@{ $router->{hardware} }) {
1930	551					569	my $hwname = $hardware->{name};
1931	551					413	my $level;
1932	551	50 100 100 100	67			455	if (
1933	556 556					4078 879	my @levels = grep { defined($_) }
1934	551					678	map { $_->{security_level} } @{ $hardware->{interfaces} }
1935							)
1936							{
1937	0	0	0			0	if (@levels >= 2 && !equal(@levels)) {
1938	0					0	err_msg "Must not use different values",
1939							" for attribute 'security_level'\n",
1940							" at $router->{name}, hardware $hwname: ", join(',', @levels);
1941							}
1942							else {
1943	0					0	$level = $levels[0];
1944							}
1945							}
1946							elsif ($hwname =~ 'inside') {
1947	66					68	$level = 100;
1948							}
1949							elsif ($hwname =~ 'outside') {
1950	64					62	$level = 0;
1951							}
1952
1953							# It is not necessary the find the exact level; what we need to know
1954							# is the relation of the security levels to each other.
1955							elsif (($level) = ($hwname =~ /(\d+)$/) and $level <= 100) {
1956							}
1957							else {
1958	19					19	$level = 50;
1959							}
1960	551					1190	$hardware->{level} = $level;
1961							}
1962	258					326	return;
1963							}
1964
1965							my $bind_nat0 = [];
1966
1967							our %routers;
1968
1969							sub read_router {
1970	650			650	0	628	my $name = shift;
1971
1972							# Extract
1973							# - router name without prefix "router:", needed to build interface name
1974							# - optional vrf name
1975	650					3062	my ($rname, $device_name, $vrf) =
1976							$name =~ /^ router : ( (.?) (?: \@ (.) )? ) $/x;
1977	650					1049	my $router = new('Router', name => $name, device_name => $device_name);
1978	650	100				1083	if (defined $vrf) {
1979
1980							# VRF value "0" would be interpreted as false by perl.
1981	6	50				9	$vrf or error_atline("Must not use '$vrf' as VRF value");
1982	6					11	$router->{vrf} = $vrf;
1983							}
1984	650					809	skip '=';
1985	650					906	skip '\{';
1986	650					982	add_description($router);
1987	650					612	while (1) {
1988	3284	100				4035	last if check '\}';
1989	2634	100 100 100 50 100 100 50 100 100 100 100 100 100				3594	if (my $managed = check_managed()) {
1990	453	50				919	$router->{managed}
1991							and error_atline("Redefining 'managed' attribute");
1992	453					688	$router->{managed} = $managed;
1993							}
1994							elsif (my @filter_only = check_assign_list('filter_only',
1995							\&read_ip_prefix_pair))
1996							{
1997	26					39	add_attribute($router, filter_only => \@filter_only);
1998							}
1999							elsif (my $model = check_model()) {
2000	465					638	add_attribute($router, model => $model);
2001							}
2002							elsif (check_flag 'no_group_code') {
2003	0					0	$router->{no_group_code} = 1;
2004							}
2005							elsif (check_flag 'no_crypto_filter') {
2006	8					17	$router->{no_crypto_filter} = 1;
2007							}
2008							elsif (check_flag 'no_protect_self') {
2009	1					2	$router->{no_protect_self} = 1;
2010							}
2011							elsif (check_flag 'strict_secondary') {
2012	0					0	$router->{strict_secondary} = 1;
2013							}
2014							elsif (check_flag 'log_deny') {
2015	1					3	$router->{log_deny} = 1;
2016							}
2017							elsif (my $routing = check_routing()) {
2018	133					195	add_attribute($router, routing => $routing);
2019							}
2020							elsif (my $owner = check_assign 'owner', \&read_identifier) {
2021	1					2	add_attribute($router, owner => $owner);
2022							}
2023							elsif (my $radius_attributes = check_radius_attributes) {
2024	8					13	add_attribute($router, radius_attributes => $radius_attributes);
2025							}
2026							elsif (my $pair = check_assign('policy_distribution_point',
2027							\&read_typed_name))
2028							{
2029	8					13	add_attribute($router, policy_distribution_point => $pair);
2030							}
2031							elsif (my @list = check_assign_list('general_permit',
2032							\&read_typed_name_or_simple_protocol))
2033							{
2034	11					20	add_attribute($router, general_permit => \@list);
2035							}
2036							else {
2037	1519					1906	my $pair = read_typed_name;
2038	1519					1988	my ($type, $name2) = @$pair;
2039	1519	100 50				3147	if ($type eq 'log') {
2040	34	50				76	defined($router->{log}->{$name2})
2041							and error_atline("Duplicate 'log' definition");
2042	34	100				45	my $modifier = check('=') ? read_identifier() : 0;
2043	34					62	$router->{log}->{$name2} = $modifier;
2044	34					46	skip(';');
2045	34					85	next;
2046							}
2047							elsif ($type ne 'interface') {
2048	0					0	syntax_err("Expected interface or log definition");
2049							}
2050
2051							# Derive interface name from router name.
2052	1485					2518	my $iname = "$rname.$name2";
2053	1485					3487	for my $interface (read_interface "interface:$iname") {
2054	1563 1563					1208 2286	push @{ $router->{interfaces} }, $interface;
2055	1563					4639	($iname = $interface->{name}) =~ s/interface://;
2056	1563	100				3197	if ($interfaces{$iname}) {
2057	3					8	error_atline("Redefining $interface->{name}");
2058							}
2059
2060							# Assign interface to global hash of interfaces.
2061	1563					2288	$interfaces{$iname} = $interface;
2062
2063							# Link interface with router object.
2064	1563					1601	$interface->{router} = $router;
2065
2066							# Link interface with network name (will be resolved later).
2067	1563					1846	$interface->{network} = $name2;
2068
2069							# Set private attribute of interface.
2070	1563	100				5774	$interface->{private} = $private if $private;
2071							}
2072							}
2073							}
2074
2075	650					867	my $model = $router->{model};
2076
2077							# Owner at vip interfaces is allowed for managed and unmanaged
2078							# devices and hence must be checked for both.
2079							{
2080	650 650					529 494	my $error;
2081	650 650					530 944	for my $interface (@{ $router->{interfaces} }) {
2082	1563	100	100 100			3171	if ($interface->{vip} && !($model && $model->{has_vip})) {
2083	2					2	$error = 1;
2084
2085							# Prevent further errors.
2086	2					3	delete $interface->{vip};
2087	2					4	delete $interface->{owner};
2088							}
2089							}
2090	650	100				1145	if ($error) {
2091	2 12					9 15	my $valid = join(', ', grep({ $router_info{$_}->{has_vip} }
2092							sort keys %router_info));
2093	2					8	err_msg("Must not use attribute 'vip' at $name\n",
2094							" 'vip' is only allowed for model $valid");
2095							}
2096							}
2097
2098	650	100				1102	if (my $managed = $router->{managed}) {
2099	453					423	my $all_routing = $router->{routing};
2100
2101	453	50				723	unless ($model) {
2102	0					0	err_msg("Missing 'model' for managed $name");
2103
2104							# Prevent further errors.
2105	0					0	$router->{model} = { name => 'unknown' };
2106							}
2107
2108							# Router is semi_managed if only routes are generated.
2109	453	100				747	if ($managed eq 'routing_only') {
2110	6					7	$router->{semi_managed} = 1;
2111	6					8	$router->{routing_only} = 1;
2112	6					11	delete $router->{managed};
2113							}
2114
2115	453	50	67			868	$router->{vrf}
2116							and not $model->{can_vrf}
2117							and err_msg("Must not use VRF at $name",
2118							" of model $model->{name}");
2119
2120							# Create objects representing hardware interfaces.
2121							# All logical interfaces using the same hardware are linked
2122							# to the same hardware object.
2123	453					360	my %hardware;
2124	453 453					361 605	for my $interface (@{ $router->{interfaces} }) {
2125
2126							# Managed router must not have short interface.
2127	1079	100				1633	if ($interface->{ip} eq 'short') {
2128	1					4	err_msg
2129							"Short definition of $interface->{name} not allowed";
2130							}
2131
2132	1079					1104	my $hw_name = $interface->{hardware};
2133
2134							# Interface of managed router needs to have a hardware
2135							# name.
2136	1079	100				1460	if (!$hw_name) {
2137
2138							# Prevent duplicate error message.
2139	1	50				3	if ($interface->{ip} ne 'short') {
2140	1					3	err_msg("Missing 'hardware' for $interface->{name}");
2141							}
2142
2143							# Prevent further errors.
2144	1					2	$hw_name = 'unknown';
2145							}
2146
2147	1079					792	my $hardware;
2148	1079	100				1645	if ($hardware = $hardware{$hw_name}) {
2149
2150							# All logical interfaces of one hardware interface
2151							# need to use the same NAT binding,
2152							# because NAT operates on hardware, not on logic.
2153	65	50	67 67			322	aref_eq(
2154							$interface->{bind_nat} \|\| $bind_nat0,
2155							$hardware->{bind_nat} \|\| $bind_nat0
2156							)
2157							or err_msg "All logical interfaces of $hw_name\n",
2158							" at $name must use identical NAT binding";
2159							}
2160							else {
2161	1014					1891	$hardware = { name => $hw_name, loopback => 1 };
2162	1014					1366	$hardware{$hw_name} = $hardware;
2163	1014 1014					772 1322	push @{ $router->{hardware} }, $hardware;
2164	1014	100				1652	if (my $nat = $interface->{bind_nat}) {
2165	67					76	$hardware->{bind_nat} = $nat;
2166							}
2167
2168							# Hardware name 'VIP' is used internally at loadbalancers.
2169	1014	50	75			1817	$hw_name eq 'VIP'
2170							and $model->{has_vip}
2171							and not $interface->{vip}
2172							and err_msg("Must not use hardware 'VIP' at",
2173							" $interface->{name}");
2174							}
2175	1079					1054	$interface->{hardware} = $hardware;
2176
2177							# Hardware keeps attribute {loopback} only if all
2178							# interfaces have attribute {loopback}.
2179	1079	100				1561	if (!$interface->{loopback}) {
2180	1054					1226	delete $hardware->{loopback};
2181							}
2182
2183							# Remember, which logical interfaces are bound
2184							# to which hardware.
2185	1079 1079					805 1742	push @{ $hardware->{interfaces} }, $interface;
2186
2187							# Don't allow 'routing=manual' at single interface, because
2188							# approve would remove manual routes otherwise.
2189							# Approve only leaves routes unchanged, if Netspoc generates
2190							# no routes at all.
2191	1079	100				1651	if ((my $routing = $interface->{routing})) {
2192	8	50				16	$routing->{name} eq 'manual' and
2193							warn_msg("'routing=manual' must only be applied",
2194							" to router, not to $interface->{name}");
2195							}
2196
2197							# Interface inherits routing attribute from router.
2198	1079	100				1427	if ($all_routing) {
2199	331		33			883	$interface->{routing} \|\|= $all_routing;
2200							}
2201	1079	50	67			3320	if ((my $routing = $interface->{routing}) &&
2202							$interface->{ip} eq 'unnumbered')
2203							{
2204	0					0	my $rname = $routing->{name};
2205	0	0				0	$rname =~ /^(?:manual\|dynamic)$/ or
2206							error_atline("Routing $rname not supported",
2207							" for unnumbered interface");
2208							}
2209							}
2210							}
2211	650	100				1090	if (my $managed = $router->{managed}) {
2212	447	100				855	if ($managed =~ /^local/) {
2213	27	100				49	$router->{filter_only} or
2214							err_msg("Missing attribute 'filter_only' for $name");
2215	27	50				44	$model->{has_io_acl} and
2216							err_msg("Must not use 'managed = $managed' at $name",
2217							" of model $model->{name}");
2218							}
2219	447	50	67			871	$router->{log_deny}
2220							and not $model->{can_log_deny}
2221							and err_msg("Must not use attribute 'log_deny' at $name",
2222							" of model $model->{name}");
2223
2224	447	100				707	if (my $hash = $router->{log}) {
2225	19	50				29	if (my $log_modifiers = $model->{log_modifiers}) {
2226	19					53	for my $name2 (sort keys %$hash) {
2227
2228							# 0: simple unmodified 'log' statement.
2229	34	100				65	my $modifier = $hash->{$name2} or next;
2230
2231	31	100				67	$log_modifiers->{$modifier} and next;
2232
2233	3					12	my $valid = join('\|', sort keys %$log_modifiers);
2234	3					11	my $what = "'log:$name2 = $modifier' at $name" .
2235							" of model $model->{name}";
2236	3	100				6	if ($valid) {
2237	2					7	err_msg("Invalid $what\n Expected one of: $valid");
2238							}
2239							else {
2240	1					4	err_msg("Unexpected $what\n Use 'log:$name2;' only.");
2241							}
2242							}
2243							}
2244							else {
2245	0					0	my ($name2) = sort keys %$hash;
2246	0					0	err_msg("Must not use attribute 'log:$name2' at $name",
2247							" of model $model->{name}");
2248							}
2249							}
2250
2251	447	50	67			861	$router->{no_protect_self}
2252							and not $model->{need_protect}
2253							and err_msg("Must not use attribute 'no_protect_self' at $name",
2254							" of model $model->{name}");
2255	447	100				727	if ($model->{need_protect}) {
2256	165					332	$router->{need_protect} = !delete $router->{no_protect_self};
2257							}
2258
2259	447	50	33			826	$router->{strict_secondary}
2260							and $managed !~ /secondary$/
2261							and err_msg("Must not use attribute 'strict_secondary' at $name.\n",
2262							" Only valid with 'managed = secondary\|local_secondary'");
2263
2264							# Detailed interface processing for managed routers.
2265	447 447					369 624	for my $interface (@{ $router->{interfaces} }) {
2266	1067	50	33			1813	if (defined $interface->{security_level}
2267							&& !$model->{has_interface_level})
2268							{
2269	0					0	warn_msg("Ignoring attribute 'security_level'",
2270							" at $interface->{name}");
2271							}
2272	1067	100	100			3121	if ($interface->{hub} or $interface->{spoke}) {
2273	21	50				37	$model->{crypto}
2274							or err_msg "Crypto not supported for $name",
2275							" of model $model->{name}";
2276							}
2277	1067	50	67 33			2121	if ($interface->{no_check}
2278							and not($interface->{hub} and $model->{do_auth}))
2279							{
2280	0					0	delete $interface->{no_check};
2281	0					0	warn_msg("Ignoring attribute 'no_check' at $interface->{name}");
2282							}
2283							}
2284
2285							# Collect bridged interfaces of this device and check
2286							# existence of corresponding layer3 device.
2287	447					442	my %layer3_seen;
2288	447 447					388 551	for my $interface (@{ $router->{interfaces} }) {
2289	1067	100				1945	next if not $interface->{ip} eq 'bridged';
2290	14					68	(my $layer3_name = $interface->{name}) =~ s/^interface:(.)\/./$1/;
2291	14					15	my $layer3_intf;
2292	14	100 50				33	if (exists $layer3_seen{$layer3_name}) {
2293	7					8	$layer3_intf = $layer3_seen{$layer3_name};
2294							}
2295							elsif ($layer3_intf = $interfaces{$layer3_name}) {
2296
2297							# Mark layer3 interface as loopback interface internally,
2298							# because we only have layer2 networks and no layer3 network.
2299	7					9	$layer3_intf->{loopback} = 1;
2300
2301							# Mark layer3 interface as such to prevent warning in
2302							# check_subnets.
2303	7					7	$layer3_intf->{is_layer3} = 1;
2304
2305	7	50				14	if ($model->{class} eq 'ASA') {
2306	7	50				16	$layer3_intf->{hardware}->{name} eq 'device'
2307							or
2308							err_msg("Layer3 $interface->{name} must use 'hardware'",
2309							" named 'device' for model 'ASA'");
2310							}
2311	7	50				23	if (my ($no_ip) = $layer3_intf->{ip} =~
2312							/^(unnumbered\|negotiated\|short\|bridged)$/)
2313							{
2314	0					0	err_msg(
2315							"Layer3 $layer3_intf->{name}",
2316							" must not be $no_ip"
2317							);
2318
2319							# Prevent further errors.
2320	0					0	$layer3_intf->{disabled} = 1;
2321	0					0	$layer3_intf = undef;
2322							}
2323							}
2324							else {
2325	0					0	err_msg("Must define interface:$layer3_name for corresponding",
2326							" bridge interfaces");
2327							}
2328
2329							# Link bridged interface to corresponding layer3 interface.
2330							# Used in path_auto_interfaces.
2331	14					16	$interface->{layer3_interface} = $layer3_intf;
2332	14					24	$layer3_seen{$layer3_name} = $layer3_intf;
2333							}
2334
2335							# Delete secondary interface of layer3 interface.
2336							# This prevents irritating error messages later.
2337	447	100				823	if (keys %layer3_seen) {
2338	7					6	my $changed;
2339	7 7					7 12	for my $interface (@{ $router->{interfaces} }) {
2340	21	50				36	my $main = $interface->{main_interface} or next;
2341	0	0				0	if ($main->{is_layer3}) {
2342	0					0	err_msg("Layer3 $main->{name} must not have",
2343							" secondary $interface->{name}");
2344	0					0	$interface = undef;
2345	0					0	$changed = 1;
2346							}
2347							}
2348	7 0 0	50				13 0 0	$router->{interfaces} = [ grep { $_ } @{ $router->{interfaces} } ]
2349							if $changed;
2350							}
2351	447	100				738	if ($model->{has_interface_level}) {
2352	258					379	set_pix_interface_level($router);
2353							}
2354	447	100				817	if ($managed =~ /^local/) {
2355	27 54 27	100				21 89 35	grep { $_->{bind_nat} } @{ $router->{interfaces} }
2356							and err_msg "Attribute 'bind_nat' is not allowed",
2357							" at interface of $name with 'managed = $managed'";
2358							}
2359	447	100				639	if ($model->{do_auth}) {
2360
2361	8 14 8	50				7 26 13	grep { $_->{hub} } @{ $router->{interfaces} }
2362							or err_msg "Attribute 'hub' needs to be defined",
2363							" at an interface of $name of model $model->{name}";
2364
2365							# Don't support NAT for VPN, otherwise code generation for VPN
2366							# devices will become more difficult.
2367	8 14 8	50				4 23 10	grep { $_->{bind_nat} } @{ $router->{interfaces} }
2368							and err_msg "Attribute 'bind_nat' is not allowed",
2369							" at interface of $name of model $model->{name}";
2370
2371	8		50			15	$router->{radius_attributes} \|\|= {};
2372							}
2373							else {
2374	439	50				732	$router->{radius_attributes}
2375							and err_msg "Attribute 'radius_attributes' is not allowed",
2376							" for $name";
2377							}
2378	447	100				757	if ($model->{no_crypto_filter}) {
2379	256					514	$router->{no_crypto_filter} = 1;
2380							}
2381							}
2382
2383							# Unmanaged device.
2384							else {
2385	203					174	my $bridged;
2386	203	50				392	if (delete $router->{owner}) {
2387	0					0	warn_msg("Ignoring attribute 'owner' at unmanaged $name");
2388							}
2389	203 203					173 270	for my $interface (@{ $router->{interfaces} }) {
2390	496	50				689	if ($interface->{hub}) {
2391	0					0	error_atline("Interface with attribute 'hub' must only be",
2392							" used at managed device");
2393							}
2394	496	50				712	if (delete $interface->{reroute_permit}) {
2395	0					0	warn_msg("Ignoring attribute 'reroute_permit'",
2396							" at unmanaged $interface->{name}");
2397							}
2398	496	50				900	if ($interface->{ip} eq 'bridged') {
2399	0					0	$bridged = 1;
2400							}
2401							}
2402
2403							# Unmanaged bridge would complicate generation of static routes.
2404	203	50				351	if ($bridged) {
2405	0					0	error_atline("Bridged interfaces must only be used",
2406							" at managed device");
2407							}
2408							}
2409
2410	650					532	my @move_locked;
2411
2412	650 650					528 838	for my $interface (@{ $router->{interfaces} }) {
2413
2414							# Automatically create a network for loopback interface.
2415	1588	100 100				2960	if ($interface->{loopback}) {
2416	39					31	my $name;
2417							my $net_name;
2418
2419							# Special handling needed for virtual loopback interfaces.
2420							# The created network needs to be shared among a group of
2421							# interfaces.
2422	39	100				57	if ($interface->{redundant}) {
2423
2424							# Shared virtual loopback network gets name
2425							# 'virtual:netname'. Don't use standard name to prevent
2426							# network from getting referenced from rules.
2427	4					7	$net_name = "virtual:$interface->{network}";
2428	4					5	$name = "network:$net_name";
2429							}
2430							else {
2431
2432							# Single loopback network needs not to get an unique name.
2433							# Take an invalid name 'router.loopback' to prevent name
2434							# clashes with real networks or other loopback networks.
2435	35					40	$name = $interface->{name};
2436	35					130	($net_name = $name) =~ s/^interface://;
2437							}
2438	39	100				90	if (not $networks{$net_name}) {
2439	37					101	my $network = new(
2440							'Network',
2441							name => $name,
2442							ip => $interface->{ip},
2443							mask => 0xffffffff,
2444
2445							# Mark as automatically created.
2446							loopback => 1,
2447							subnet_of => delete $interface->{subnet_of},
2448							is_layer3 => $interface->{is_layer3},
2449							);
2450	37	50				77	if (my $private = $interface->{private}) {
2451	0					0	$network->{private} = $private;
2452							}
2453	37					56	$networks{$net_name} = $network;
2454							}
2455	39					50	$interface->{network} = $net_name;
2456							}
2457
2458							# Generate tunnel interface.
2459							elsif (my $crypto = $interface->{spoke}) {
2460	25					225	my $net_name = "tunnel:$rname";
2461	25					40	my $iname = "$rname.$net_name";
2462	25					64	my $tunnel_intf = new(
2463							'Interface',
2464							name => "interface:$iname",
2465							ip => 'tunnel',
2466							router => $router,
2467							network => $net_name,
2468							real_interface => $interface
2469							);
2470	25					36	for my $key (qw(hardware routing private bind_nat id)) {
2471	125	100				193	if ($interface->{$key}) {
2472	14					27	$tunnel_intf->{$key} = $interface->{$key};
2473							}
2474							}
2475	25	50				57	if ($interfaces{$iname}) {
2476	0					0	error_atline("Redefining $tunnel_intf->{name}");
2477							}
2478	25					39	$interfaces{$iname} = $tunnel_intf;
2479	25 25					18 34	push @{ $router->{interfaces} }, $tunnel_intf;
2480
2481							# Create tunnel network.
2482	25					51	my $tunnel_net = new(
2483							'Network',
2484							name => "network:$net_name",
2485							ip => 'tunnel'
2486							);
2487	25	50				44	if (my $private = $interface->{private}) {
2488	0					0	$tunnel_net->{private} = $private;
2489							}
2490	25					40	$networks{$net_name} = $tunnel_net;
2491
2492							# Tunnel network will later be attached to crypto hub.
2493	25 25					18 47	push @{ $crypto2spokes{$crypto} }, $tunnel_net;
2494							}
2495
2496	1588	100	100			5687	if (($interface->{spoke} \|\| $interface->{hub}) &&
2497							!$interface->{no_check})
2498							{
2499	40					61	push @move_locked, $interface;
2500							}
2501							}
2502
2503	650	100				1128	move_locked_interfaces(\@move_locked) if @move_locked;
2504
2505	650					1015	return $router;
2506							}
2507
2508							# No traffic must traverse crypto or secondary interface.
2509							# Hence split router into separate instances, one instance for each
2510							# crypto/secondary interface.
2511							# Splitted routers are tied by identical attribute {device_name}.
2512							sub move_locked_interfaces {
2513	39			39	0	37	my ($interfaces) = @_;
2514	39					45	for my $interface (@$interfaces) {
2515	40					35	my $orig_router = $interface->{router};
2516	40					39	my $name = $orig_router->{name};
2517	40					127	my $new_router = new('Router',
2518							%$orig_router,
2519							orig_router => $orig_router,
2520							interfaces => [ $interface ]);
2521	40					56	$interface->{router} = $new_router;
2522	40					35	push @router_fragments, $new_router;
2523
2524							# Don't check fragment for reachability.
2525	40					45	delete $new_router->{policy_distribution_point};
2526
2527							# Remove interface from old router.
2528							# Retain copy of original interfaces.
2529	40					36	my $interfaces = $orig_router->{interfaces};
2530	40		100			138	$orig_router->{orig_interfaces} \|\|= [ @$interfaces ];
2531	40					60	aref_delete($interfaces, $interface);
2532
2533	40	100				441	if ($orig_router->{managed}) {
2534	18					20	my $hardware = $interface->{hardware};
2535	18					25	$new_router->{hardware} = [ $hardware ];
2536	18					22	my $hw_list = $orig_router->{hardware};
2537
2538							# Retain copy of original hardware.
2539	18					30	$orig_router->{orig_hardware} = [ @$hw_list ];
2540	18					24	aref_delete($hw_list, $hardware);
2541	18 18	50				15 41	1 == @{ $hardware->{interfaces} } or
2542							err_msg("Crypto $interface->{name} must not share hardware",
2543							" with other interfaces");
2544	18	100				46	if (my $hash = $orig_router->{radius_attributes}) {
2545
2546							# Copy hash, because it is changed per device later.
2547	6					25	$new_router->{radius_attributes} = { %$hash };
2548							}
2549							}
2550							}
2551	39					43	return;
2552							}
2553
2554							our %aggregates;
2555
2556							sub read_aggregate {
2557	52			52	0	65	my $name = shift;
2558	52					92	my $aggregate = new('Network', name => $name, is_aggregate => 1);
2559	52	50				106	$aggregate->{private} = $private if $private;
2560	52					74	skip '=';
2561	52					84	skip '\{';
2562	52					83	add_description($aggregate);
2563	52					53	while (1) {
2564	145	100				176	last if check '\}';
2565	93	100 100 100 100 50				175	if (my ($ip, $mask) = check_assign 'ip', \&read_ip_prefix) {
2566	23					36	add_attribute($aggregate, ip => $ip);
2567	23					29	add_attribute($aggregate, mask => $mask);
2568							}
2569							elsif (my $owner = check_assign 'owner', \&read_identifier) {
2570	10					22	add_attribute($aggregate, owner => $owner);
2571							}
2572							elsif (my $link = check_assign 'link', \&read_typed_name) {
2573	52					89	add_attribute($aggregate, link => $link);
2574							}
2575							elsif (check_flag 'has_unenforceable') {
2576	2					8	$aggregate->{has_unenforceable} = 1;
2577							}
2578							elsif (my $nat_name = check_nat_name()) {
2579	6					15	my $nat = read_nat("nat:$nat_name");
2580	6	50				12	$nat->{dynamic} or error_atline("$nat->{name} must be dynamic");
2581	6	50				14	$aggregate->{nat}->{$nat_name}
2582							and error_atline("Duplicate NAT definition");
2583	6					13	$aggregate->{nat}->{$nat_name} = $nat;
2584							}
2585							else {
2586	0					0	syntax_err("Expected some valid attribute");
2587							}
2588							}
2589	52	50				132	$aggregate->{link} or err_msg("Attribute 'link' must be defined for $name");
2590	52					66	my $ip = $aggregate->{ip};
2591	52					49	my $mask = $aggregate->{mask};
2592	52	100				85	if ($ip) {
2593	21					59	for my $key (keys %$aggregate) {
2594	107 749	50				96 942	next if grep({ $key eq $_ }
2595							qw( name ip mask link is_aggregate private nat));
2596	0					0	error_atline("Must not use attribute $key if mask is set");
2597							}
2598							}
2599							else {
2600	31					50	$aggregate->{ip} = $aggregate->{mask} = 0;
2601							}
2602	52					76	return $aggregate;
2603							}
2604
2605							sub check_router_attributes {
2606	13			13	0	15	my ($parent) = @_;
2607
2608							# Add name for error messages.
2609	13					35	my $result = { name => "router_attributes of $parent" };
2610	13	100				18	check 'router_attributes' or return;
2611	7					10	skip '=';
2612	7					9	skip '\{';
2613	7					8	while (1) {
2614	14	100				19	last if check '\}';
2615	7	100 100 50				14	if (my $owner = check_assign 'owner', \&read_identifier) {
2616	1					2	add_attribute($result, owner => $owner);
2617							}
2618							elsif (my $pair = check_assign('policy_distribution_point',
2619							\&read_typed_name))
2620							{
2621	2					3	add_attribute($result, policy_distribution_point => $pair);
2622							}
2623							elsif (my @list = check_assign_list('general_permit',
2624							\&read_typed_name_or_simple_protocol))
2625							{
2626	4					6	add_attribute($result, general_permit => \@list);
2627							}
2628							else {
2629	0					0	syntax_err("Unexpected attribute");
2630							}
2631							}
2632	7					16	return $result;
2633							}
2634
2635							our %areas;
2636
2637							sub read_area {
2638	66			66	0	71	my $name = shift;
2639	66					111	my $area = new('Area', name => $name);
2640	66					93	skip '=';
2641	66					159	skip '\{';
2642	66					112	add_description($area);
2643	66					67	while (1) {
2644	176	100				213	last if check '\}';
2645	110	100 100 100 100 100 100 50				212	if (my @elements = check_assign_list('border', \&read_intersection)) {
2646	40 44	50 50				49 239	if (grep { $_->[0] ne 'interface' \|\| ref $_->[1] } @elements) {
2647	0					0	error_atline "Must only use interface names in border";
2648	0					0	@elements = ();
2649							}
2650	40					63	add_attribute($area, border => \@elements);
2651							}
2652							elsif (@elements =
2653							check_assign_list('inclusive_border', \&read_intersection))
2654							{
2655	12 18	50 50				17 146	if (grep { $_->[0] ne 'interface' \|\| ref $_->[1] } @elements) {
2656	0					0	error_atline "Must only use interface names in border";
2657	0					0	@elements = ();
2658							}
2659	12					23	add_attribute($area, inclusive_border => \@elements);
2660							}
2661							elsif (check_flag 'auto_border') {
2662	2					4	$area->{auto_border} = 1;
2663							}
2664							elsif (my $pair = check_assign 'anchor', \&read_typed_name) {
2665	17	50	33			86	if ($pair->[0] ne 'network' \|\| ref $pair->[1]) {
2666	0					0	error_atline "Must only use network name in 'anchor'";
2667	0					0	$pair = undef;
2668							}
2669	17					37	add_attribute($area, anchor => $pair);
2670							}
2671							elsif (my $owner = check_assign 'owner', \&read_identifier) {
2672	26					41	add_attribute($area, owner => $owner);
2673							}
2674							elsif (my $router_attributes = check_router_attributes($name)) {
2675	7					11	add_attribute($area, router_attributes => $router_attributes);
2676							}
2677							elsif (my $nat_name = check_nat_name()) {
2678	6					13	my $nat = read_nat("nat:$nat_name");
2679	6	50				13	$nat->{dynamic} or error_atline("$nat->{name} must be dynamic");
2680	6	50				15	$area->{nat}->{$nat_name}
2681							and error_atline("Duplicate NAT definition");
2682	6					14	$area->{nat}->{$nat_name} = $nat;
2683							}
2684							else {
2685	0					0	syntax_err("Expected some valid attribute");
2686							}
2687							}
2688	66	50	60			364	(($area->{border} \|\| $area->{inclusive_border}) && $area->{anchor})
2689							and err_msg("Attribute 'anchor' must not be defined together with",
2690							" 'border' or 'inclusive_border' for $name");
2691	66	50	75			251	($area->{anchor} \|\| $area->{border} \|\| $area->{inclusive_border})
2692							or err_msg("At least one of attributes 'border', 'inclusive_border'",
2693							" or 'anchor' must be defined for $name");
2694	66					82	return $area;
2695							}
2696
2697							our %groups;
2698
2699							sub read_group {
2700	9			9	0	12	my $name = shift;
2701	9					18	skip '=';
2702	9					19	my $group = new('Group', name => $name);
2703	9	50				21	$group->{private} = $private if $private;
2704	9					16	add_description($group);
2705	9					20	my @elements = read_list_or_null \&read_intersection;
2706	9					373	$group->{elements} = \@elements;
2707	9					15	return $group;
2708							}
2709
2710							our %protocolgroups;
2711
2712							sub read_protocolgroup {
2713	2			2	0	3	my $name = shift;
2714	2					2	skip '=';
2715	2					5	my @pairs = read_list_or_null \&read_typed_name_or_simple_protocol;
2716	2					4	return new('Protocolgroup', name => $name, elements => \@pairs);
2717							}
2718
2719							sub read_port_range {
2720	286	100		286	0	337	if (defined(my $port1 = check_int)) {
2721	267	50				504	error_atline("Too large port number $port1") if $port1 > 65535;
2722	267	50				391	error_atline("Invalid port number '0'") if $port1 == 0;
2723	267	100				341	if (check '-') {
2724	21	50				29	if (defined(my $port2 = check_int)) {
2725	21	50				42	error_atline("Too large port number $port2") if $port2 > 65535;
2726	21	50				36	error_atline("Invalid port number '0'") if $port2 == 0;
2727	21	50				34	error_atline("Invalid port range $port1-$port2")
2728							if $port1 > $port2;
2729	21	100	67			46	if ($port1 == 1 && $port2 == 65535) {
2730	3					5	return $aref_tcp_any;
2731							}
2732							else {
2733	18					43	return [ $port1, $port2 ];
2734							}
2735							}
2736							else {
2737	0					0	syntax_err("Missing second port in port range");
2738							}
2739							}
2740							else {
2741	246					558	return [ $port1, $port1 ];
2742							}
2743							}
2744							else {
2745	19					27	return $aref_tcp_any;
2746							}
2747							}
2748
2749							sub read_port_ranges {
2750	278			278	0	275	my ($prt) = @_;
2751	278					369	my $range = read_port_range;
2752	278	100				415	if (check ':') {
2753	8	100				24	if ($range ne $aref_tcp_any) {
2754	7					10	$prt->{src_range} = $range;
2755							}
2756	8					11	$prt->{dst_range} = read_port_range;
2757							}
2758							else {
2759	270					576	$prt->{dst_range} = $range;
2760							}
2761	278					351	return;
2762							}
2763
2764							sub read_icmp_type_code {
2765	37			37	0	42	my ($prt) = @_;
2766	37	100				48	if (defined(my $type = check_int)) {
2767	30	50				63	error_atline("Too large ICMP type $type") if $type > 255;
2768	30	50				42	if (check '/') {
2769	0	0				0	if (defined(my $code = check_int)) {
2770	0	0				0	error_atline("Too large ICMP code $code") if $code > 255;
2771	0					0	$prt->{type} = $type;
2772	0					0	$prt->{code} = $code;
2773							}
2774							else {
2775	0					0	syntax_err("Expected ICMP code");
2776							}
2777							}
2778							else {
2779	30					49	$prt->{type} = $type;
2780	30	100	75			158	if ($type == 0 \|\| $type == 3 \|\| $type == 11) {
2781	12					22	$prt->{flags}->{stateless_icmp} = 1;
2782							}
2783							}
2784							}
2785							else {
2786
2787							# No type and code given.
2788							}
2789	37					48	return;
2790							}
2791
2792							sub read_proto_nr {
2793	1			1	0	1	my ($prt) = @_;
2794	1	50				2	if (defined(my $nr = check_int)) {
2795	1	50				2	error_atline("Too large protocol number $nr") if $nr > 255;
2796	1	50				3	error_atline("Invalid protocol number '0'") if $nr == 0;
2797	1	50 50 50				4	if ($nr == 1) {
2798	0					0	$prt->{proto} = 'icmp';
2799
2800							# No ICMP type and code given.
2801							}
2802							elsif ($nr == 4) {
2803	0					0	$prt->{proto} = 'tcp';
2804	0					0	$prt->{dst_range} = $aref_tcp_any;
2805							}
2806							elsif ($nr == 17) {
2807	0					0	$prt->{proto} = 'udp';
2808	0					0	$prt->{dst_range} = $aref_tcp_any;
2809							}
2810							else {
2811	1					2	$prt->{proto} = $nr;
2812							}
2813							}
2814							else {
2815	0					0	syntax_err("Expected protocol number");
2816							}
2817	1					2	return;
2818							}
2819
2820							sub gen_protocol_name {
2821	317			317	0	284	my ($protocol) = @_;
2822	317					351	my $proto = $protocol->{proto};
2823	317					284	my $name = $proto;
2824
2825	317	100 100 100	100			914	if ($proto eq 'ip') {
2826							}
2827							elsif ($proto eq 'tcp' or $proto eq 'udp') {
2828							my $port_name = sub {
2829	262			262		393	my ($v1, $v2) = @_;
2830	262	100 100	67			451	if ($v1 == $v2) {
2831	228					371	return ($v1);
2832							}
2833							elsif ($v1 == 1 and $v2 == 65535) {
2834	19					30	return ('');
2835							}
2836							else {
2837	15					36	return ("$v1-$v2");
2838							}
2839	262					818	};
2840	262					293	my $src_range = $protocol->{src_range};
2841	262		33			606	my $src_port = $src_range && $port_name->(@$src_range);
2842	262 262					246 480	my $dst_port = $port_name->(@{ $protocol->{dst_range} });
2843	262					249	my $port;
2844	262	50				393	$port = "$src_port:" if $src_port;
2845	262	100				742	$port .= "$dst_port" if $dst_port;
2846	262	100				1167	$name .= " $port" if $port;
2847							}
2848							elsif ($proto eq 'icmp') {
2849	31	100				66	if (defined(my $type = $protocol->{type})) {
2850	24	50				39	if (defined(my $code = $protocol->{code})) {
2851	0					0	$name = "$proto $type/$code";
2852							}
2853							else {
2854	24					45	$name = "$proto $type";
2855							}
2856							}
2857							}
2858							else {
2859	1					2	$name = "proto $proto";
2860							}
2861	317					456	return $name;
2862							}
2863
2864							our %protocols;
2865
2866							sub cache_anonymous_protocol {
2867	317			317	0	329	my ($protocol) = @_;
2868	317					403	my $name = gen_protocol_name($protocol);
2869	317	100				614	if (my $cached = $protocols{$name}) {
2870	25					36	return $cached;
2871							}
2872							else {
2873	292					356	$protocol->{name} = $name;
2874	292					314	$protocol->{is_used} = 1;
2875	292					407	$protocols{$name} = $protocol;
2876	292					387	return $protocol;
2877							}
2878							}
2879
2880							sub read_simple_protocol {
2881	345			345	0	334	my $name = shift;
2882	345					398	my $protocol = {};
2883	345					618	my $proto = read_identifier();
2884	345	100 100 100 100 50				857	if ($proto eq 'ip') {
2885	29					47	$protocol->{proto} = 'ip';
2886							}
2887							elsif ($proto eq 'tcp') {
2888	264					401	$protocol->{proto} = 'tcp';
2889	264					399	read_port_ranges($protocol);
2890							}
2891							elsif ($proto eq 'udp') {
2892	14					25	$protocol->{proto} = 'udp';
2893	14					19	read_port_ranges $protocol;
2894							}
2895							elsif ($proto eq 'icmp') {
2896	37					64	$protocol->{proto} = 'icmp';
2897	37					59	read_icmp_type_code $protocol;
2898							}
2899							elsif ($proto eq 'proto') {
2900	1					3	read_proto_nr $protocol;
2901							}
2902							else {
2903	0					0	error_atline("Unknown protocol '$proto'");
2904
2905							# Prevent further errors.
2906	0					0	$protocol->{proto} = 'ip';
2907							}
2908	345	100				447	if ($name) {
2909	28					43	$protocol->{name} = $name;
2910							}
2911							else {
2912	317					430	$protocol = cache_anonymous_protocol($protocol);
2913							}
2914	345					824	return $protocol;
2915							}
2916
2917							sub check_protocol_flags {
2918	28			28	0	32	my ($protocol) = @_;
2919	28					40	while (check ',') {
2920	7					11	my $flag = read_identifier;
2921	7	100 50				34	if ($flag =~ /^(src\|dst)_(net\|any)$/) {
2922	3					13	$protocol->{flags}->{$1}->{$2} = 1;
2923							}
2924							elsif ($flag =~
2925							/^(?:stateless\|reversed\|oneway\|overlaps\|no_check_supernet_rules)/)
2926							{
2927	4					11	$protocol->{flags}->{$flag} = 1;
2928							}
2929							else {
2930	0					0	syntax_err("Unknown flag '$flag'");
2931							}
2932							}
2933	28					31	return;
2934							}
2935
2936							sub read_typed_name_or_simple_protocol {
2937	350		67	350	0	430	return (check_typed_name() \|\| read_simple_protocol());
2938							}
2939
2940							sub read_protocol {
2941	28			28	0	35	my $name = shift;
2942	28					37	skip '=';
2943	28					53	my $protocol = read_simple_protocol($name);
2944	28					47	check_protocol_flags($protocol);
2945	28					40	skip ';';
2946	28					39	return $protocol;
2947							}
2948
2949							our %services;
2950
2951							sub assign_union_allow_user {
2952	622			622	0	624	my ($name) = @_;
2953	622					701	skip $name;
2954	622					876	skip '=';
2955	622					1065	local $user_object->{active} = 1;
2956	622					619	$user_object->{refcount} = 0;
2957	622					813	my @result = read_union ';';
2958	622					1354	return \@result, $user_object->{refcount};
2959							}
2960
2961							sub read_service {
2962	274			274	0	313	my ($name) = @_;
2963	274					608	my $service = { name => $name, rules => [] };
2964	274	50				473	$service->{private} = $private if $private;
2965	274					354	skip '=';
2966	274					402	skip '\{';
2967	274					429	add_description($service);
2968	274					268	while (1) {
2969	282	100				367	last if check 'user';
2970	8	100 100 50 100 50 50 0				19	if (my $sub_owner = check_assign 'sub_owner', \&read_identifier) {
2971	1					2	add_attribute($service, sub_owner => $sub_owner);
2972							}
2973							elsif (my @other = check_assign_list 'overlaps', \&read_typed_name) {
2974	4					7	add_attribute($service, overlaps => \@other);
2975							}
2976							elsif (my $visible = check_assign('visible', \&read_owner_pattern)) {
2977	0					0	add_attribute($service, visible => $visible);
2978							}
2979							elsif (check_flag('multi_owner')) {
2980	1					2	$service->{multi_owner} = 1;
2981							}
2982							elsif (check_flag('unknown_owner')) {
2983	0					0	$service->{unknown_owner} = 1;
2984							}
2985							elsif (check_flag('has_unenforceable')) {
2986	2					4	$service->{has_unenforceable} = 1;
2987							}
2988							elsif (check_flag('disabled')) {
2989	0					0	$service->{disabled} = 1;
2990							}
2991							else {
2992	0					0	syntax_err("Expected some valid attribute or definition of 'user'");
2993							}
2994							}
2995
2996							# 'user' has already been read above.
2997	274					417	skip '=';
2998	274	50				402	if (check 'foreach') {
2999	0					0	$service->{foreach} = 1;
3000							}
3001	274					504	my @elements = read_list \&read_intersection;
3002	274					456	$service->{user} = \@elements;
3003
3004	274					429	while (1) {
3005	585	100				742	last if check '\}';
3006	311	50				693	if (my $action = check_permit_deny) {
3007	311					451	my ($src, $src_user) = assign_union_allow_user 'src';
3008	311					435	my ($dst, $dst_user) = assign_union_allow_user 'dst';
3009	311					946	my $prt = [
3010							read_assign_list(
3011							'prt', \&read_typed_name_or_simple_protocol
3012							)
3013							];
3014	311					316	my $log;
3015	311	100				551	if (my @list = check_assign_list('log', \&read_identifier)) {
3016	18					20	$log = \@list;
3017							}
3018							$src_user
3019	311	50	67			709	or $dst_user
3020							or error_atline("Rule must use keyword 'user'");
3021	311	50	33 0			650	if ($service->{foreach} and not($src_user and $dst_user)) {
3022	0					0	warn_msg("Rule of $name should reference 'user'",
3023							" in 'src' and 'dst'\n",
3024							" because service has keyword 'foreach'");
3025							}
3026	311	100 100				1262	my $rule = {
3027							service => $service,
3028							action => $action,
3029							src => $src,
3030							dst => $dst,
3031							prt => $prt,
3032							has_user => $src_user ? $dst_user ? 'both' : 'src' : 'dst',
3033							};
3034	311	100				492	$rule->{log} = $log if $log;
3035	311 311					257 624	push @{ $service->{rules} }, $rule;
3036							}
3037							else {
3038	0					0	syntax_err("Expected 'permit' or 'deny'");
3039							}
3040							}
3041	274					408	return $service;
3042							}
3043
3044							our %pathrestrictions;
3045
3046							sub read_pathrestriction {
3047	29			29	0	32	my $name = shift;
3048	29					41	skip '=';
3049	29					46	my $restriction = new('Pathrestriction', name => $name);
3050	29	50				51	$restriction->{private} = $private if $private;
3051	29					40	add_description($restriction);
3052	29					49	my @elements = read_list \&read_intersection;
3053	29					49	$restriction->{elements} = \@elements;
3054	29					40	return $restriction;
3055							}
3056
3057							sub read_attributed_object {
3058	40			40	0	36	my ($name, $attr_descr) = @_;
3059	40					69	my $object = { name => $name };
3060	40					56	skip '=';
3061	40					58	skip '\{';
3062	40					60	add_description($object);
3063	40					39	while (1) {
3064	282	100				333	last if check '\}';
3065	242					333	my $attribute = read_identifier;
3066	242	50				533	my $val_descr = $attr_descr->{$attribute}
3067							or syntax_err("Unknown attribute '$attribute'");
3068	242					286	skip '=';
3069	242					220	my $val;
3070	242	100 50				417	if (my $values = $val_descr->{values}) {
3071	174					218	$val = read_identifier;
3072	174 1016	50				208 1418	grep { $_ eq $val } @$values
3073							or syntax_err("Invalid value");
3074							}
3075							elsif (my $fun = $val_descr->{function}) {
3076	68					87	$val = &$fun;
3077							}
3078							else {
3079	0					0	internal_err();
3080							}
3081	242					287	skip ';';
3082	242					348	add_attribute($object, $attribute => $val);
3083							}
3084	40					108	for my $attribute (keys %$attr_descr) {
3085	300					240	my $description = $attr_descr->{$attribute};
3086	300	100				416	unless (defined $object->{$attribute}) {
3087	58	50				79	if (my $default = $description->{default}) {
3088	58					83	$object->{$attribute} = $default;
3089							}
3090							else {
3091	0					0	error_atline("Missing '$attribute' for $object->{name}");
3092							}
3093							}
3094
3095							# Convert from syntax to internal values, e.g. 'none' => undef.
3096	300	100				456	if (my $map = $description->{map}) {
3097	140					129	my $value = $object->{$attribute};
3098	140	100				258	if (exists $map->{$value}) {
3099	47					78	$object->{$attribute} = $map->{$value};
3100							}
3101							}
3102							}
3103	40					76	return $object;
3104							}
3105
3106							my %isakmp_attributes = (
3107
3108							# This one is ignored and is optional.
3109							identity => {
3110							values => [qw( address fqdn )],
3111							default => 'none',
3112							map => { none => undef }
3113							},
3114							nat_traversal => {
3115							values => [qw( on additional off )],
3116							default => 'off',
3117							map => { off => undef }
3118							},
3119							authentication => { values => [qw( preshare rsasig )], },
3120							encryption => { values => [qw( aes aes192 aes256 des 3des )], },
3121							hash => { values => [qw( md5 sha sha256 sha384 sha512 )], },
3122							ike_version => { values => [ 1, 2 ], default => 1, },
3123							lifetime => { function => \&read_time_val, },
3124							group => { values => [ 1, 2, 5, 14, 15, 16, 19, 20, 21, 24 ], },
3125							lifetime => { function => \&read_time_val, },
3126							trust_point => {
3127							function => \&read_identifier,
3128							default => 'none',
3129							map => { none => undef }
3130							},
3131							);
3132
3133							our %isakmp;
3134
3135							sub read_isakmp {
3136	20			20	0	21	my ($name) = @_;
3137	20					31	return read_attributed_object $name, \%isakmp_attributes;
3138							}
3139
3140							my %ipsec_attributes = (
3141							key_exchange => { function => \&read_typed_name, },
3142							esp_encryption => {
3143							values => [qw( none aes aes192 aes256 des 3des )],
3144							default => 'none',
3145							map => { none => undef }
3146							},
3147							esp_authentication => {
3148							values => [qw( none md5_hmac sha_hmac md5 sha sha256 sha384 sha512 )],
3149							default => 'none',
3150							map => { none => undef,
3151
3152							# Compatibility for old version.
3153							md5_hmac => 'md5', sha_hmac => 'sha', }
3154							},
3155							ah => {
3156							values => [qw( none md5_hmac sha_hmac md5 sha sha256 sha384 sha512 )],
3157							default => 'none',
3158							map => { none => undef, md5_hmac => 'md5', sha_hmac => 'sha', }
3159							},
3160							pfs_group => {
3161							values => [qw( none 1 2 5 14 15 16 19 20 21 24 )],
3162							default => 'none',
3163							map => { none => undef }
3164							},
3165							lifetime => { function => \&read_time_val, },
3166							);
3167
3168							our %ipsec;
3169
3170							sub read_ipsec {
3171	20			20	0	18	my ($name) = @_;
3172	20					36	return read_attributed_object $name, \%ipsec_attributes;
3173							}
3174
3175							our %crypto;
3176
3177							sub read_crypto {
3178	21			21	0	20	my ($name) = @_;
3179	21					27	skip '=';
3180	21					32	skip '\{';
3181	21					36	my $crypto = { name => $name };
3182	21	50				33	$crypto->{private} = $private if $private;
3183	21					31	add_description($crypto);
3184	21					21	while (1) {
3185	45	100				54	last if check '\}';
3186	24	100 50				38	if (check_flag 'detailed_crypto_acl') {
3187	3					6	$crypto->{detailed_crypto_acl} = 1;
3188							}
3189							elsif (my $type = check_assign 'type', \&read_typed_name) {
3190	21	50				41	$crypto->{type}
3191							and error_atline("Redefining 'type' attribute");
3192	21					36	$crypto->{type} = $type;
3193							}
3194							else {
3195	0					0	syntax_err("Expected valid attribute");
3196							}
3197							}
3198	21	50				42	$crypto->{type} or error_atline("Missing 'type' for $name");
3199	21					23	return $crypto;
3200							}
3201
3202							our %owners;
3203
3204							sub read_owner {
3205	64			64	0	66	my $name = shift;
3206	64					85	my $owner = new('Owner', name => $name);
3207	64					90	skip '=';
3208	64					96	skip '\{';
3209	64					105	add_description($owner);
3210	64					63	while (1) {
3211	154	100				187	last if check '\}';
3212	90	100 100 100 100 100 100 50				161	if (my $alias = check_assign('alias', \&read_string)) {
3213	3	50				5	$owner->{alias}
3214							and error_atline("Redefining 'alias' attribute");
3215	3					6	$owner->{alias} = $alias;
3216							}
3217							elsif (my @admins = check_assign_list('admins', \&read_name)) {
3218	59	50				111	$owner->{admins}
3219							and error_atline("Redefining 'admins' attribute");
3220	59					116	$owner->{admins} = \@admins;
3221							}
3222							elsif (my @watchers = check_assign_list('watchers', \&read_name)) {
3223	14	50				28	if ($from_json->{watchers}) {
3224	0					0	error_atline("Watchers must only be defined",
3225							" in JSON/ directory");
3226							}
3227	14	50				24	$owner->{watchers}
3228							and error_atline("Redefining 'watchers' attribute");
3229	14					26	$owner->{watchers} = \@watchers;
3230							}
3231							elsif (check_flag 'extend_only') {
3232	9					17	$owner->{extend_only} = 1;
3233							}
3234							elsif (check_flag 'extend_unbounded') {
3235	1					2	$owner->{extend_unbounded} = 1;
3236							}
3237							elsif (check_flag 'extend') {
3238	3					7	$owner->{extend} = 1;
3239							}
3240							elsif (check_flag 'show_all') {
3241	1					3	$owner->{show_all} = 1;
3242							}
3243							else {
3244	0					0	syntax_err("Expected valid attribute");
3245							}
3246							}
3247	64	100				133	if (!$owner->{admins}) {
3248	5	100	67			19	$owner->{extend_only} and $owner->{watchers} or
3249							error_atline("Missing attribute 'admins'");
3250	5					8	$owner->{admins} = [];
3251							}
3252	64					75	return $owner;
3253							}
3254
3255							my %global_type = (
3256							router => [ \&read_router, \%routers ],
3257							network => [ \&read_network, \%networks ],
3258							any => [ \&read_aggregate, \%aggregates ],
3259							area => [ \&read_area, \%areas ],
3260							owner => [ \&read_owner, \%owners ],
3261							group => [ \&read_group, \%groups ],
3262							protocol => [ \&read_protocol, \%protocols ],
3263							protocolgroup => [ \&read_protocolgroup, \%protocolgroups ],
3264							service => [ \&read_service, \%services ],
3265							pathrestriction => [ \&read_pathrestriction, \%pathrestrictions ],
3266							isakmp => [ \&read_isakmp, \%isakmp ],
3267							ipsec => [ \&read_ipsec, \%ipsec ],
3268							crypto => [ \&read_crypto, \%crypto ],
3269							);
3270
3271							sub read_netspoc {
3272
3273							# Check for global definitions.
3274	2288	50		2288	0	2677	my $pair = check_typed_name or syntax_err('');
3275	2288					3154	my ($type, $name) = @$pair;
3276	2288	50				4421	my $descr = $global_type{$type}
3277							or syntax_err("Unknown global definition");
3278	2288					2208	my ($fun, $hash) = @$descr;
3279	2288					5661	my $result = $fun->("$type:$name");
3280	2288					3407	$result->{file} = $current_file;
3281	2288	50				4026	if (my $other = $hash->{$name}) {
3282	0					0	err_msg("Duplicate definition of $type:$name in",
3283							" $current_file and $other->{file}");
3284							}
3285
3286							# Result is not used in this module but can be useful
3287							# when this function is called from outside.
3288	2288					6114	return $hash->{$name} = $result;
3289							}
3290
3291							# Read input from file and process it by function which is given as argument.
3292							sub read_file {
3293	342			342	0	408	local $current_file = shift;
3294	342					300	my $read_syntax = shift;
3295
3296							# Read file as one large line.
3297	342					796	local $/;
3298	342					304	local $input;
3299
3300	342	50				510	if (defined $current_file) {
3301	342	50				4043	open(my $fh, '<', $current_file)
3302							or fatal_err("Can't open $current_file: $!");
3303
3304							# Fill buffer with content of whole file.
3305							# Content is implicitly freed when subroutine is left.
3306	342					4102	$input = <$fh>;
3307	342					1357	close $fh;
3308							}
3309							else {
3310	0					0	$current_file = 'STDIN';
3311	0					0	$input = <>;
3312							}
3313	342					418	local $line = 1;
3314	342					1146	my $length = length $input;
3315	342					577	while (skip_space_and_comment, pos $input != $length) {
3316	2288					2564	&$read_syntax;
3317							}
3318	342					1540	return;
3319							}
3320
3321							# Try to read file 'config' in toplevel directory $path.
3322							sub read_config {
3323	326			326	0	319	my ($path) = @_;
3324	326					287	my %result;
3325							my $read_config_data = sub {
3326	0			0		0	my $key = read_identifier();
3327	0	0				0	valid_config_key($key) or syntax_err("Invalid keyword");
3328	0					0	skip('=');
3329	0					0	my $val = read_identifier;
3330	0	0				0	if (my $expected = check_config_pair($key, $val)) {
3331	0					0	syntax_err("Expected value matching '$expected'");
3332							}
3333	0					0	skip(';');
3334	0					0	$result{$key} = $val;
3335	326					1069	};
3336
3337	326	100	67			1993	if (defined $path && -d $path) {
3338	305	50				4586	opendir(my $dh, $path) or fatal_err("Can't opendir $path: $!");
3339	305 919	50				2268 1644	if (grep { $_ eq 'config' } readdir $dh) {
3340	0					0	$path = "$path/config";
3341	0					0	read_file $path, $read_config_data;
3342							}
3343	305					1460	closedir $dh;
3344							}
3345	326					1444	return \%result;
3346							}
3347
3348							sub read_json_watchers {
3349	0			0	0	0	my ($path) = @_;
3350	0	0				0	opendir(my $dh, $path) or fatal_err("Can't opendir $path: $!");
3351	0 0					0 0	my @files = map({ Encode::decode($filename_encode, $_) } readdir $dh);
3352	0					0	closedir $dh;
3353	0					0	for my $owner_name (@files) {
3354	0	0				0	next if $owner_name =~ /^\./;
3355	0	0				0	next if $owner_name =~ m/$config{ignore_files}/o;
3356	0					0	my $path = "$path/$owner_name";
3357	0	0				0	opendir(my $dh, $path) or fatal_err("Can't opendir $path: $!");
3358	0 0					0 0	my @files = map({ Encode::decode($filename_encode, $_) } readdir $dh);
3359	0					0	closedir $dh;
3360	0					0	for my $file (@files) {
3361	0	0				0	next if $file =~ /^\./;
3362	0	0				0	next if $file =~ m/$config{ignore_files}/o;
3363	0					0	my $path = "$path/$file";
3364	0	0				0	if ($file ne 'watchers') {
3365	0					0	err_msg("Ignoring $path");
3366	0					0	next;
3367							}
3368	0	0				0	open (my $fh, '<', $path) or fatal_err("Can't open $path");
3369	0					0	my $data;
3370							{
3371	0 0					0 0	local $/ = undef;
3372	0					0	$data = from_json( <$fh> );
3373							}
3374	0					0	close($fh);
3375	0					0	my $owner = $owners{$owner_name};
3376	0	0				0	if (! $owner) {
3377	0					0	err_msg("Referencing unknown owner:$owner_name in $path");
3378	0					0	next;
3379							}
3380	0	0				0	$owner->{watchers} and
3381							err_msg("Redefining watcher of owner:$owner_name from $path");
3382	0					0	$owner->{watchers} = $data;
3383							}
3384							}
3385	0					0	return;
3386							}
3387
3388							sub read_json {
3389	0			0	0	0	my ($path) = @_;
3390	0	0				0	opendir(my $dh, $path) or fatal_err("Can't opendir $path: $!");
3391	0 0					0 0	my @files = map({ Encode::decode($filename_encode, $_) } readdir $dh);
3392	0					0	closedir $dh;
3393	0					0	for my $file (@files) {
3394	0	0				0	next if $file =~ /^\./;
3395	0	0				0	next if $file =~ m/$config{ignore_files}/o;
3396	0					0	my $path = "$path/$file";
3397	0	0				0	if ($file ne 'owner') {
3398	0					0	err_msg("Ignoring $path");
3399	0					0	next;
3400							}
3401	0					0	read_json_watchers($path);
3402							}
3403	0					0	return;
3404							}
3405
3406							sub read_file_or_dir {
3407	337			337	0	369	my ($path, $read_syntax) = @_;
3408	337		100			1101	$read_syntax \|\|= \&read_netspoc;
3409
3410							# Handle toplevel file.
3411	337	100	67			1866	if (!(defined $path && -d $path)) {
3412	32					61	read_file($path, $read_syntax);
3413	32					54	return;
3414							}
3415
3416							# Recursively read files and directories.
3417	305					260	my $read_nested_files;
3418							my $read_nested_files0 = sub {
3419	313			313		322	my ($path, $read_syntax) = @_;
3420	313	100				1148	if (-d $path) {
3421	3	50				22	opendir(my $dh, $path) or fatal_err("Can't opendir $path: $!");
3422	3					19	while (my $file = Encode::decode($filename_encode, readdir $dh)) {
3423	10	100				34	next if $file =~ /^\./;
3424	4	50				35	next if $file =~ m/$config{ignore_files}/o;
3425	4					10	my $path = "$path/$file";
3426	4					10	$read_nested_files->($path, $read_syntax);
3427							}
3428	3					17	closedir $dh;
3429							}
3430							else {
3431	310					483	read_file $path, $read_syntax;
3432							}
3433	305					1137	};
3434
3435							# Special handling for "*.private".
3436							$read_nested_files = sub {
3437	313			313		364	my ($path, $read_syntax) = @_;
3438
3439							# Handle private directories and files.
3440	313	100				723	if (my ($name) = ($path =~ m'([^/]*)\.private$')) {
3441	5	100				9	if ($private) {
3442	1					4	err_msg("Nested private context is not supported:\n $path");
3443							}
3444	5					7	local $private = $name;
3445	5					9	$read_nested_files0->($path, $read_syntax);
3446							}
3447							else {
3448	308					410	$read_nested_files0->($path, $read_syntax);
3449							}
3450	305					712	};
3451
3452							# Handle toplevel directory.
3453							# Special handling for "config", "raw" and "JSON".
3454	305	50				1902	opendir(my $dh, $path) or fatal_err("Can't opendir $path: $!");
3455	305 919					1442 1719	my @files = map({ Encode::decode($filename_encode, $_) } readdir $dh);
3456	305					854	closedir $dh;
3457
3458	305 919	50				373 1538	if (grep { $_ eq 'JSON' } @files) {
3459	0	0				0	$can_json or
3460							fatal_err("JSON module must be installed to read $path/JSON");
3461	0					0	$from_json = { JSON => 1 };
3462	0	0				0	if (-e "$path/JSON/owner") {
3463	0					0	$from_json->{watchers} = 1;
3464							}
3465							}
3466
3467	305					391	for my $file (@files) {
3468
3469	919	100				2014	next if $file =~ /^\./;
3470	309	50				1954	next if $file =~ m/$config{ignore_files}/o;
3471
3472							# Ignore special files/directories.
3473	309	50				669	next if $file =~ /^(config\|raw\|JSON)$/;
3474
3475	309					651	my $path = "$path/$file";
3476	309					465	$read_nested_files->($path, $read_syntax);
3477							}
3478	305	50				717	if (keys %$from_json) {
3479	0					0	read_json("$path/JSON");
3480							}
3481	305					729	return;
3482							}
3483
3484							sub show_read_statistics {
3485	305			305	0	366	my $n = keys %networks;
3486	305					279	my $h = keys %hosts;
3487	305					293	my $r = keys %routers;
3488	305					269	my $g = keys %groups;
3489	305					277	my $s = keys %protocols;
3490	305					253	my $sg = keys %protocolgroups;
3491	305					261	my $p = keys %services;
3492	305					946	info("Read $r routers, $n networks, $h hosts");
3493	305					874	info("Read $p services, $g groups, $s protocols, $sg protocol groups");
3494	305					309	return;
3495							}
3496
3497							## no critic (RequireArgUnpacking RequireFinalReturn)
3498
3499							# Type checking functions
3500	1734			1734	0	4900	sub is_network { ref($_[0]) eq 'Network'; }
3501	3835			3835	0	9549	sub is_router { ref($_[0]) eq 'Router'; }
3502	3010			3010	0	9065	sub is_interface { ref($_[0]) eq 'Interface'; }
3503	1002			1002	0	1824	sub is_host { ref($_[0]) eq 'Host'; }
3504	64			64	0	214	sub is_subnet { ref($_[0]) eq 'Subnet'; }
3505	118			118	0	232	sub is_area { ref($_[0]) eq 'Area'; }
3506	464			464	0	693	sub is_zone { ref($_[0]) eq 'Zone'; }
3507	1246			1246	0	3685	sub is_group { ref($_[0]) eq 'Group'; }
3508	0			0	0	0	sub is_protocolgroup { ref($_[0]) eq 'Protocolgroup'; }
3509	2219			2219	0	5533	sub is_objectgroup { ref($_[0]) eq 'Objectgroup'; }
3510	128			128	0	294	sub is_chain { ref($_[0]) eq 'Chain'; }
3511	1809			1809	0	4011	sub is_autointerface { ref($_[0]) eq 'Autointerface'; }
3512
3513							## use critic
3514
3515							sub print_rule {
3516	61			61	0	57	my ($rule) = @_;
3517	61					47	my $extra = '';
3518	61		67			188	my $service = $rule->{rule} && $rule->{rule}->{service};
3519	61	50				92	$extra .= " $rule->{for_router}" if $rule->{for_router};
3520	61	100				92	$extra .= " stateless" if $rule->{stateless};
3521	61	50				80	$extra .= " stateless_icmp" if $rule->{stateless_icmp};
3522	61	100				128	$extra .= " of $service->{name}" if $service;
3523	61		67			142	my $prt = $rule->{orig_prt} \|\| $rule->{prt};
3524	61	50				88	my $action = $rule->{deny} ? 'deny' : 'permit';
3525	61	50				100	if (my $chain = $rule->{chain}) {
3526	0					0	$action = $chain->{name};
3527							}
3528							return
3529	61					361	$action
3530							. " src=$rule->{src}->{name}; dst=$rule->{dst}->{name}; "
3531							. "prt=$prt->{name};$extra";
3532							}
3533
3534							##############################################################################
3535							# Order protocols
3536							##############################################################################
3537
3538							# Hash for converting a reference of a protocol back to this protocol.
3539							our %ref2prt;
3540
3541							# Look up a protocol object by its defining attributes.
3542							my %prt_hash;
3543
3544							sub prepare_prt_ordering {
3545	4954			4954	0	3830	my ($prt) = @_;
3546	4954					4556	my $proto = $prt->{proto};
3547	4954					3685	my $main_prt;
3548	4954	100 100 100	100			14543	if ($proto eq 'tcp' or $proto eq 'udp') {
3549
3550							# Convert src and dst port ranges from arrays to real protocol objects.
3551							# This is used in function expand_rules via expand_protocols:
3552							# An unexpanded rule has references to TCP and UDP protocols
3553							# with combined src and dst port ranges. An expanded rule has
3554							# distinct references to src and dst protocols with a single
3555							# port range.
3556	2577					2458	for my $where ('src_range', 'dst_range') {
3557
3558							# An array with low and high port.
3559	5154	100				8201	my $range = $prt->{$where} or next;
3560	3246					5962	my $key = join ':', @$range;
3561	3246					3539	my $range_prt = $prt_hash{$proto}->{$key};
3562	3246	100				4147	if (not $range_prt) {
3563	2225					4570	$range_prt = {
3564							name => $prt->{name},
3565							proto => $proto,
3566							range => $range,
3567							};
3568	2225					2977	$prt_hash{$proto}->{$key} = $range_prt;
3569
3570							# Set up ref2prt.
3571	2225					4418	$ref2prt{$range_prt} = $range_prt;
3572							}
3573	3246					5535	$prt->{$where} = $range_prt;
3574							}
3575							}
3576							elsif ($proto eq 'icmp') {
3577	365					533	my $type = $prt->{type};
3578	365					349	my $code = $prt->{code};
3579	365	50 100				537	my $key = defined $type ? (defined $code ? "$type:$code" : $type) : '';
3580	365	100				1077	$main_prt = $prt_hash{$proto}->{$key}
3581							or $prt_hash{$proto}->{$key} = $prt;
3582							}
3583							elsif ($proto eq 'ip') {
3584	356	100				775	$main_prt = $prt_hash{$proto}
3585							or $prt_hash{$proto} = $prt;
3586							}
3587							else {
3588
3589							# Other protocol.
3590	1656					1436	my $key = $proto;
3591	1656	100				3365	$main_prt = $prt_hash{proto}->{$key}
3592							or $prt_hash{proto}->{$key} = $prt;
3593							}
3594	4954	100				6883	if ($main_prt) {
3595
3596							# Found duplicate protocol definition. Link $prt with $main_prt.
3597							# We link all duplicate protocols to the first protocol found.
3598							# This assures that we always reach the main protocol from any duplicate
3599							# protocol in one step via ->{main}. This is used later to substitute
3600							# occurrences of $prt with $main_prt.
3601	33					44	$prt->{main} = $main_prt;
3602							}
3603	4954					5275	return;
3604							}
3605
3606							sub order_icmp {
3607	331			331	0	325	my ($hash, $up) = @_;
3608
3609							# Handle 'icmp any'.
3610	331	50				590	if (my $prt = $hash->{''}) {
3611	331					325	$prt->{up} = $up;
3612	331					481	$up = $prt;
3613							}
3614	331					583	for my $prt (values %$hash) {
3615
3616							# 'icmp any' has been handled above.
3617	358	100 50				620	if (!defined $prt->{type}) {
3618							}
3619							elsif (defined $prt->{code}) {
3620	0		0			0	$prt->{up} = ($hash->{ $prt->{type} } or $up);
3621							}
3622							else {
3623	27					33	$prt->{up} = $up;
3624							}
3625
3626							# Set up ref2prt.
3627	358					1928	$ref2prt{$prt} = $prt;
3628							}
3629	331					403	return;
3630							}
3631
3632							sub order_proto {
3633	331			331	0	322	my ($hash, $up) = @_;
3634	331					553	for my $prt (values %$hash) {
3635	1655					1478	$prt->{up} = $up;
3636
3637							# Set up ref2prt.
3638	1655					2440	$ref2prt{$prt} = $prt;
3639							}
3640	331					369	return;
3641							}
3642
3643							# Set {up} relation from port range to the smallest port range which
3644							# includes it.
3645							# If no including range is found, link it with next larger protocol.
3646							# Set attribute {has_neighbor} to range adjacent to upper port.
3647							# Find overlapping ranges and split one of them to eliminate the overlap.
3648							# Set attribute {split} at original range, referencing pair of splitted ranges.
3649							sub order_ranges {
3650	662			662	0	641	my ($range_href, $up) = @_;
3651	2801	50				5335	my @sorted =
3652
3653							# Sort by low port. If low ports are equal, sort reverse by high port.
3654							# I.e. larger ranges coming first, if there are multiple ranges
3655							# with identical low port.
3656							sort {
3657	662					1604	$a->{range}->[0] <=> $b->{range}->[0]
3658							\|\| $b->{range}->[1] <=> $a->{range}->[1]
3659							} values %$range_href;
3660
3661							# Check current range [a1, a2] for sub-ranges, starting at position $i.
3662							# Return position of range which isn't sub-range or undef
3663							# if end of array is reached.
3664	662					497	my $check_subrange;
3665
3666							$check_subrange = sub {
3667	2225			2225		2662	my ($a, $a1, $a2, $i) = @_;
3668	2225					1602	while (1) {
3669	3279	100				4754	return if $i == @sorted;
3670	2617					2065	my $b = $sorted[$i];
3671	2617 2617					1834 3283	my ($b1, $b2) = @{ $b->{range} };
3672
3673							# Neighbors
3674							# aaaabbbb
3675	2617	100				3610	if ($a2 + 1 == $b1) {
3676
3677							# Mark protocol as candidate for joining of port ranges during
3678							# optimization.
3679	36					47	$a->{has_neighbor} = $b->{has_neighbor} = 1;
3680							}
3681
3682							# Not related.
3683							# aaaa bbbbb
3684	2617	100				3834	return $i if $a2 < $b1;
3685
3686							# $a includes $b.
3687							# aaaaaaa
3688							# bbbbb
3689	1564	100				2109	if ($a2 >= $b2) {
3690	1563					1406	$b->{up} = $a;
3691
3692							# debug("$b->{name} [$b1-$b2] < $a->{name} [$a1-$a2]");
3693	1563					2892	$i = $check_subrange->($b, $b1, $b2, $i + 1);
3694
3695							# Stop at end of array.
3696	1563	100				2584	$i or return;
3697	1053					896	next;
3698							}
3699
3700							# $a and $b are overlapping.
3701							# aaaaa
3702							# bbbbbb
3703							# Split $b in two parts $x and $y with $x included by $b:
3704							# aaaaa
3705							# xxxyyy
3706	1					1	my $x1 = $b1;
3707	1					2	my $x2 = $a2;
3708	1					1	my $y1 = $a2 + 1;
3709	1					1	my $y2 = $b2;
3710
3711							# debug("$b->{name} [$b1-$b2] split into [$x1-$x2] and [$y1-$y2]");
3712							my $find_or_insert_range = sub {
3713	2					3	my ($a1, $a2, $i, $orig, $prefix) = @_;
3714	2					2	while (1) {
3715	3	100				4	if ($i == @sorted) {
3716	1					1	last;
3717							}
3718	2					3	my $b = $sorted[$i];
3719	2 2					2 3	my ($b1, $b2) = @{ $b->{range} };
3720
3721							# New range starts at higher position and therefore must
3722							# be inserted behind current range.
3723	2	100				4	if ($a1 > $b1) {
3724	1					1	$i++;
3725	1					1	next;
3726							}
3727
3728							# New and current range start a same position.
3729	1	50				2	if ($a1 == $b1) {
3730
3731							# New range is smaller and therefore must be inserted
3732							# behind current range.
3733	1	50				2	if ($a2 < $b2) {
3734	0					0	$i++;
3735	0					0	next;
3736							}
3737
3738							# Found identical range, return this one.
3739	1	50				2	if ($a2 == $b2) {
3740
3741							# debug("Splitted range is already defined: $b->{name}");
3742	1					2	return $b;
3743							}
3744
3745							# New range is larger than current range and therefore
3746							# must be inserted in front of current one.
3747	0					0	last;
3748							}
3749
3750							# New range starts at lower position than current one.
3751							# It must be inserted in front of current range.
3752	0					0	last;
3753							}
3754	1					5	my $new_range = {
3755							name => "$prefix$orig->{name}",
3756							proto => $orig->{proto},
3757							range => [ $a1, $a2 ],
3758
3759							# Mark for range optimization.
3760							has_neighbor => 1
3761							};
3762
3763							# Insert new range at position $i.
3764	1					4	splice @sorted, $i, 0, $new_range;
3765
3766							# Set up ref2prt.
3767	1					1	$ref2prt{$new_range} = $new_range;
3768
3769	1					2	return $new_range;
3770	1					4	};
3771	1					2	my $left = $find_or_insert_range->($x1, $x2, $i + 1, $b, 'lpart_');
3772	1					2	my $rigth = $find_or_insert_range->($y1, $y2, $i + 1, $b, 'rpart_');
3773	1					2	$b->{split} = [ $left, $rigth ];
3774
3775							# Continue processing with next element.
3776	1					5	$i++;
3777							}
3778	662					2339	};
3779
3780							# Array wont be empty because $prt_tcp and $prt_udp are defined internally.
3781	662	50				1127	@sorted or internal_err("Unexpected empty array");
3782
3783	662					576	my $a = $sorted[0];
3784	662					683	$a->{up} = $up;
3785	662 662					528 1027	my ($a1, $a2) = @{ $a->{range} };
3786
3787							# Ranges "TCP any" and "UDP any" 1..65535 are defined internally,
3788							# they include all other ranges.
3789	662	50	33			2119	$a1 == 1 and $a2 == 65535
3790							or internal_err("Expected $a->{name} to have range 1..65535");
3791
3792							# There can't be any port which isn't included by ranges "TCP any"
3793							# or "UDP any".
3794	662	50				916	$check_subrange->($a, $a1, $a2, 1) and internal_err();
3795	662					744	return;
3796							}
3797
3798							sub expand_splitted_protocol {
3799	290			290	0	281	my ($prt) = @_;
3800
3801							# Handle unset src_range.
3802	290	100 100				585	if (not $prt) {
3803	19					30	return $prt;
3804							}
3805							elsif (my $split = $prt->{split}) {
3806	1					1	my ($prt1, $prt2) = @$split;
3807	1					3	return (expand_splitted_protocol($prt1),
3808							expand_splitted_protocol($prt2));
3809							}
3810							else {
3811	270					391	return $prt;
3812							}
3813							}
3814
3815							# Protocol 'ip' is needed later for implementing secondary rules and
3816							# automatically generated deny rules.
3817							my $prt_ip;
3818
3819							# Protocol 'ICMP any', needed in optimization of chains for iptables.
3820							my $prt_icmp;
3821
3822							# Protocol 'TCP any'.
3823							my $prt_tcp;
3824
3825							# Protocol 'UDP any'.
3826							my $prt_udp;
3827
3828							# DHCP server.
3829							my $prt_bootps;
3830
3831							# IPSec: Internet key exchange.
3832							# Source and destination port (range) is set to 500.
3833							my $prt_ike;
3834
3835							# IPSec: NAT traversal.
3836							my $prt_natt;
3837
3838							# IPSec: encryption security payload.
3839							my $prt_esp;
3840
3841							# IPSec: authentication header.
3842							my $prt_ah;
3843
3844							# Port range 'TCP any'; assigned in sub order_protocols below.
3845							my $range_tcp_any;
3846
3847							# Port range 'tcp established' is needed later for reverse rules
3848							# and assigned below.
3849							my $range_tcp_established;
3850
3851							# Order protocols. We need this to simplify optimization.
3852							# Additionally add internal predefined protocols.
3853							sub order_protocols {
3854	331			331	0	453	progress('Arranging protocols');
3855
3856							# Internal protocols need to be processed before user defined protocols,
3857							# because we want to avoid handling of {main} for internal protocols.
3858							# $prt_tcp and $prt_udp need to be processed before all other TCP and UDP
3859							# protocols, because otherwise the range 1..65535 would get a misleading
3860							# name.
3861	331 2317	100				718 3917	for my $prt (
3862							$prt_ip, $prt_icmp, $prt_tcp,
3863							$prt_udp, $prt_bootps, $prt_ike, $prt_natt,
3864							$prt_esp, $prt_ah,
3865							map({ $_->{prt} ? ($_->{prt}) : () }
3866							values %routing_info, values %xxrp_info),
3867							values %protocols
3868							)
3869							{
3870	4954					5354	prepare_prt_ordering $prt;
3871							}
3872
3873	331					456	$range_tcp_any = $prt_tcp->{dst_range};
3874	331					1262	$range_tcp_established = {
3875							%$range_tcp_any,
3876							name => 'reversed:TCP_ANY',
3877							established => 1
3878							};
3879	331					666	$range_tcp_established->{up} = $range_tcp_any;
3880
3881	331					282	my $up = $prt_ip;
3882	331					568	order_ranges($prt_hash{tcp}, $up);
3883	331					464	order_ranges($prt_hash{udp}, $up);
3884	331					508	order_icmp($prt_hash{icmp}, $up);
3885	331					461	order_proto($prt_hash{proto}, $up);
3886
3887							# Set up ref2prt.
3888	331					458	$ref2prt{$prt_ip} = $prt_ip;
3889	331					330	return;
3890							}
3891
3892							####################################################################
3893							# Link topology elements each with another
3894							####################################################################
3895
3896							sub expand_group;
3897
3898							sub link_to_owner {
3899	2401			2401	0	1856	my ($obj, $key) = @_;
3900	2401		100			5014	$key \|\|= 'owner';
3901	2401	100				3476	if (my $value = $obj->{$key}) {
3902	66	100				125	if (my $owner = $owners{$value}) {
3903	64					127	return $obj->{$key} = $owner;
3904							}
3905	2					8	err_msg("Can't resolve reference to '$value'",
3906							" in attribute '$key' of $obj->{name}");
3907	2					4	delete $obj->{$key};
3908							}
3909	2337					3462	return;
3910							}
3911
3912							sub link_to_real_owner {
3913	2335			2335	0	1897	my ($obj, $key) = @_;
3914	2335	100				2514	if (my $owner = link_to_owner($obj, $key)) {
3915	39	100				70	if ($owner->{extend_only}) {
3916
3917							# Prevent further errors.
3918	3					4	delete $owner->{extend_only};
3919	3					11	err_msg("$owner->{name} with attribute 'extend_only'",
3920							" must only be used at area,\n not at $obj->{name}");
3921							}
3922							}
3923	2335					2253	return;
3924							}
3925
3926							# Element of attribute 'watchers' of owner A is allowed to reference
3927							# some other owner B. In this case all admins and watchers of B are
3928							# added to watchers of A.
3929							sub expand_watchers {
3930	69			69	0	68	my ($owner) = @_;
3931	69					75	my $names = $owner->{watchers};
3932
3933							# No wathers given.
3934	69	100				98	if (!$names) {
3935	51					67	return $owner->{admins};
3936							}
3937
3938							# Owners, referenced in $names have already been resolved.
3939	18	100				31	if ($owner->{watching_owners}) {
3940	3 3					3 6	return [ @{ $owner->{admins} }, @$names ];
3941							}
3942	15	100				29	if ($names eq 'recursive') {
3943	1					3	err_msg("Found recursive definition of watchers in $owner->{name}");
3944	1					4	return $owner->{watchers} = [];
3945							}
3946	14					15	$owner->{watchers} = 'recursive';
3947	14					17	my $watching_owners = [];
3948	14					12	my @expanded;
3949	14					18	for my $name (@$names) {
3950	15	100				41	if (my ($o_name) = ($name =~ /^owner:(.*)$/)) {
3951	6					8	my $owner_b = $owners{$o_name};
3952	6	100				10	if (!$owner_b) {
3953	1					5	err_msg("Unknown owner:$o_name referenced in watcher of",
3954							" $owner->{name}");
3955	1					2	next;
3956							}
3957	5					5	push @$watching_owners, $owner_b;
3958	5 5					5 15	push @expanded, @{ expand_watchers($owner_b) };
3959							}
3960							else {
3961	9					21	push @expanded, $name;
3962							}
3963							}
3964	14					21	$owner->{watchers} = \@expanded;
3965
3966							# Mark: no need to expand again and for cut-netspoc.
3967	14					14	$owner->{watching_owners} = $watching_owners;
3968
3969	14 14					13 39	return [ @{ $owner->{admins} }, @expanded ];
3970							}
3971
3972							sub link_owners {
3973
3974	337			337	0	274	my %alias2owner;
3975
3976							# Use sort to get deterministic error messages.
3977	337					860	for my $name (sort keys %owners) {
3978	64					81	my $owner = $owners{$name};
3979
3980							# Check for unique alias names.
3981	64		67			202	my $alias = $owner->{alias} \|\| $name;
3982	64	100				107	if (my $other = $alias2owner{$alias}) {
3983	2					2	my $descr1 = $owner->{name};
3984	2	100				7	$owner->{alias} and $descr1 .= " with alias '$owner->{alias}'";
3985	2					2	my $descr2 = $other->{name};
3986	2	50				5	$other->{alias} and $descr2 .= " with alias '$other->{alias}'";
3987	2					6	err_msg("Name conflict between owners\n - $descr1\n - $descr2");
3988							}
3989							else {
3990	62					84	$alias2owner{$alias} = $owner;
3991							}
3992
3993							# Check and expand referenced owners in watchers.
3994	64					86	expand_watchers($owner);
3995
3996							# Check email addresses in admins and watchers.
3997	64					76	for my $attr (qw( admins watchers )) {
3998	128 128					100 235	for my $email (@{ $owner->{$attr} }) {
3999
4000							# Check email syntax.
4001							# Only 7 bit ASCII
4002							# Local part definition from wikipedia,
4003							# without space and other quoted characters
4004	74	50				61	do {
4005	70 70 70			70		452 89 374	use bytes;
4006	74	100				4459	$email =~
4007							m/^ [\w.!\#$%&''*+\/=?^_``{\|}~-]+ \@ [\w.-]+ $/x \|\|
4008							$email eq 'guest';
4009							}
4010							or err_msg("Invalid email address (ASCII only)",
4011							" in $attr of $owner->{name}: $email");
4012
4013							# Normalize email to lower case.
4014	74					325	$email = lc($email);
4015							}
4016							}
4017
4018							# Check for duplicate email addresses
4019							# in admins, watchers and between admins and watchers.
4020	64 64 64	100				63 74 106	if (find_duplicates(@{ $owner->{admins} }, @{ $owner->{watchers} })) {
4021	1					2	for my $attr (qw(admins watchers)) {
4022	2 2	100				2 4	if (my @emails = find_duplicates(@{ $owner->{$attr} })) {
4023	1 1					2 2	$owner->{$attr} = [ unique(@{ $owner->{$attr} }) ];
4024	1					6	err_msg("Duplicates in $attr of $owner->{name}: ",
4025							join(', ', @emails));
4026							}
4027							}
4028	1 1	50				2 2	if (my @duplicates =
4029	1					1	find_duplicates(@{ $owner->{admins} }, @{ $owner->{watchers} }))
4030							{
4031	1					4	err_msg("Duplicates in admins/watchers of $owner->{name}: ",
4032							join(', ', @duplicates));
4033							}
4034							}
4035							}
4036	337					672	for my $network (values %networks) {
4037	1115					1274	link_to_real_owner($network);
4038	1115 1115					783 1851	for my $host (@{ $network->{hosts} }) {
4039	181					219	link_to_real_owner($host);
4040							}
4041							}
4042	337					562	for my $aggregate (values %aggregates) {
4043	52					64	link_to_real_owner($aggregate);
4044							}
4045	337					529	for my $area (values %areas) {
4046	66					80	link_to_owner($area);
4047	66	100				142	if (my $router_attributes = $area->{router_attributes}) {
4048	7					62	link_to_real_owner($router_attributes);
4049							}
4050							}
4051	337					500	for my $router (values %routers, @router_fragments) {
4052	690					773	link_to_real_owner($router);
4053	690	100				1414	$router->{model}->{has_vip} or next;
4054	7 7					8 10	for my $interface (@{ $router->{interfaces} }) {
4055	16					20	link_to_real_owner($interface);
4056							}
4057							}
4058	337					525	for my $service (values %services) {
4059	274					330	link_to_real_owner($service, 'sub_owner');
4060							}
4061	337					399	return;
4062							}
4063
4064							sub link_policy_distribution_point {
4065	697			697	0	589	my ($obj) = @_;
4066	697	100				1254	my $pair = $obj->{policy_distribution_point} or return;
4067	10					15	my ($type, $name) = @$pair;
4068	10	50				21	if ($type ne 'host') {
4069	0					0	err_msg("Must only use 'host' in 'policy_distribution_point'",
4070							" of $obj->{name}");
4071
4072							# Prevent further errors;
4073	0					0	delete $obj->{policy_distribution_point};
4074	0					0	return;
4075							}
4076	10					13	my $host = $hosts{$name};
4077	10	50				22	if (!$host) {
4078	0					0	warn_msg("Ignoring undefined host:$name",
4079							" in 'policy_distribution_point' of $obj->{name}");
4080
4081							# Prevent further errors;
4082	0					0	delete $obj->{policy_distribution_point};
4083	0					0	return;
4084							}
4085	10					12	$obj->{policy_distribution_point} = $host;
4086	10					14	return;
4087							}
4088
4089							sub link_general_permit {
4090	697			697	0	597	my ($obj) = @_;
4091	697	100				1388	my $list = $obj->{general_permit} or return;
4092	21					24	my $context = $obj->{name};
4093
4094							# Sort protocols and src_range/dst_range/orig_prt triples by name,
4095							# so we can compare value lists of attribute general_permit for
4096							# redundancy during inheritance.
4097	9	100 100				33	$list = $obj->{general_permit} =
4098	21					32	[ sort { (ref $a eq 'ARRAY' ? $a->[2]->{name} : $a->{name})
4099							cmp
4100							(ref $b eq 'ARRAY' ? $b->[2]->{name} : $b->{name}) }
4101	21					16	@{ split_protocols(expand_protocols($list, $context)) } ];
4102
4103							# Don't allow port ranges. This wouldn't work, because
4104							# gen_reverse_rules doesn't handle generally permitted protocols.
4105	21					39	for my $prt (@$list) {
4106	28					23	my $orig_prt;
4107							my $src_range;
4108	0					0	my $range;
4109	28	100				44	if (ref $prt eq 'ARRAY') {
4110	5					6	($src_range, my $dst_range, $orig_prt) = @$prt;
4111	5					6	$range = $dst_range->{range};
4112							}
4113							else {
4114	23	100				55	$range = $prt->{range} or next;
4115	1					1	$orig_prt = $prt;
4116							}
4117	6					6	my @reason;
4118	6	50				10	if (my $flags = $orig_prt->{flags}) {
4119	0					0	push @reason, 'modifiers';
4120							}
4121	6	100	50			26	if ($src_range \|\| $range && $range ne $aref_tcp_any) {
4122	2					2	push @reason, 'ports';
4123							}
4124	6	100				15	if (@reason) {
4125	2					3	my $reason = join ' or ', @reason;
4126	2					8	err_msg("Must not use '$orig_prt->{name}' with $reason",
4127							" in general_permit of $context");
4128							}
4129							}
4130	21					32	return;
4131							}
4132
4133							# Link areas with referenced interfaces or network.
4134							sub link_areas {
4135	337			337	0	536	for my $area (values %areas) {
4136	66	100				115	if ($area->{anchor}) {
4137	17					41	my @elements =
4138	17					19	@{ expand_group([ $area->{anchor} ], $area->{name}) };
4139	17	50				41	if (@elements == 1) {
4140	17					19	my $obj = $elements[0];
4141	17	50				28	if (is_network $obj) {
4142	17					28	$area->{anchor} = $obj;
4143							}
4144							else {
4145	0					0	err_msg
4146							"Unexpected $obj->{name} in anchor of $area->{name}";
4147
4148							# Prevent further errors.
4149	0					0	delete $area->{anchor};
4150							}
4151							}
4152							else {
4153	0					0	err_msg
4154							"Expected exactly one element in anchor of $area->{name}";
4155	0					0	delete $area->{anchor};
4156							}
4157
4158							}
4159							else {
4160	49					57	for my $attr (qw(border inclusive_border)) {
4161	98	100				200	next if !$area->{$attr};
4162	52					109	$area->{$attr} = expand_group($area->{$attr}, $area->{name});
4163	52 52					82 74	for my $obj (@{ $area->{$attr} }) {
4164	62	50				86	if (is_interface $obj) {
4165	62					68	my $router = $obj->{router};
4166	62	50				103	$router->{managed}
4167							or err_msg "Referencing unmanaged $obj->{name} ",
4168							"from $area->{name}";
4169
4170							# Reverse swapped main and virtual interface.
4171	62	100				172	if (my $main_interface = $obj->{main_interface}) {
4172	2					5	$obj = $main_interface;
4173							}
4174							}
4175							else {
4176	0					0	err_msg
4177							"Unexpected $obj->{name} in $attr of $area->{name}";
4178
4179							# Prevent further errors.
4180	0					0	delete $area->{$attr};
4181							}
4182							}
4183							}
4184							}
4185	66	100				162	if (my $router_attributes = $area->{router_attributes}) {
4186	7					10	link_policy_distribution_point($router_attributes);
4187	7					9	link_general_permit($router_attributes);
4188							}
4189							}
4190	337					319	return;
4191							}
4192
4193							# Link interfaces with networks in both directions.
4194							sub link_interfaces {
4195	690			690	0	586	my ($router) = @_;
4196	690 690					546 952	for my $interface (@{ $router->{interfaces} }) {
4197	1588					1696	my $net_name = $interface->{network};
4198	1588					1827	my $network = $networks{$net_name};
4199
4200	1588	50				2282	unless ($network) {
4201	0					0	my $msg = "Referencing undefined network:$net_name"
4202							. " from $interface->{name}";
4203	0	0				0	if ($interface->{disabled}) {
4204	0					0	warn_msg($msg);
4205							}
4206							else {
4207	0					0	err_msg($msg);
4208
4209							# Prevent further errors.
4210	0					0	$interface->{disabled} = 1;
4211							}
4212
4213							# Prevent further errors.
4214							# This case is handled in disable_behind.
4215	0					0	$interface->{network} = undef;
4216	0					0	next;
4217							}
4218
4219	1588					1426	$interface->{network} = $network;
4220
4221							# Private network must be connected to private interface
4222							# of same context.
4223	1588	100				2544	if (my $private1 = $network->{private}) {
4224	3	100				4	if (my $private2 = $interface->{private}) {
4225	2	100				10	$private1 eq $private2
4226							or err_msg("$private2.private $interface->{name} must not",
4227							" be connected to $private1.private",
4228							" $network->{name}");
4229							}
4230							else {
4231	1					5	err_msg("Public $interface->{name} must not be connected to",
4232							" $private1.private $network->{name}");
4233							}
4234							}
4235
4236							# Public network may connect to private interface.
4237							# The owner of a private context can prevent a public network from
4238							# connecting to a private interface by simply connecting an own private
4239							# network to the private interface.
4240
4241	1588 1588					1141 2252	push @{ $network->{interfaces} }, $interface;
4242	1588					1993	check_interface_ip($interface, $network);
4243							}
4244	690					714	return;
4245							}
4246
4247							sub check_interface_ip {
4248	1608			1608	0	1344	my ($interface, $network) = @_;
4249	1608					1513	my $ip = $interface->{ip};
4250	1608					1376	my $network_ip = $network->{ip};
4251	1608	100 100 50 100 100				5487	if ($ip =~ /^(?:short\|tunnel)$/) {
4252
4253							# Nothing to check:
4254							# short interface may be linked to arbitrary network,
4255							# tunnel interfaces and networks have been generated internally.
4256							}
4257							elsif ($ip eq 'unnumbered') {
4258	13	50				20	$network_ip eq 'unnumbered'
4259							or err_msg("Unnumbered $interface->{name} must not be linked ",
4260							"to $network->{name}");
4261							}
4262							elsif ($network_ip eq 'unnumbered') {
4263	0					0	err_msg("$interface->{name} must not be linked ",
4264							"to unnumbered $network->{name}");
4265							}
4266							elsif ($ip eq 'negotiated') {
4267							}
4268							elsif ($ip eq 'bridged') {
4269
4270							# Nothing to be checked: attribute 'bridged' is set automatically
4271							# for an interface without IP and linked to bridged network.
4272							}
4273							else {
4274
4275							# Check compatibility of interface IP and network IP/mask.
4276	1330					1142	my $mask = $network->{mask};
4277	1330	50				1620	if (not(match_ip($ip, $network_ip, $mask))) {
4278	0					0	err_msg("$interface->{name}'s IP doesn't match ",
4279							"$network->{name}'s IP/mask");
4280							}
4281	1330	100				1768	if ($mask == 0xffffffff) {
4282	40	100				72	if (not $network->{loopback}) {
4283	1					5	warn_msg("$interface->{name} has address of its network.\n",
4284							" Remove definition of $network->{name} and\n",
4285							" add attribute 'loopback' at",
4286							" interface definition.");
4287							}
4288							}
4289							else {
4290	1290	50				2091	if ($ip == $network_ip) {
4291	0					0	err_msg("$interface->{name} has address of its network");
4292							}
4293	1290					1484	my $broadcast = $network_ip + complement_32bit $mask;
4294	1290	50				1968	if ($ip == $broadcast) {
4295	0					0	err_msg("$interface->{name} has broadcast address");
4296							}
4297							}
4298							}
4299	1608					2578	return;
4300							}
4301
4302							# Iterate over all interfaces of all routers.
4303							# Don't use values %interfaces because we want to traverse the interfaces
4304							# in a deterministic order.
4305							sub link_routers {
4306	337			337	0	947	for my $router (sort(by_name values %routers), @router_fragments) {
4307	690					874	link_interfaces($router);
4308	690					888	link_policy_distribution_point($router);
4309	690					773	link_general_permit($router);
4310							}
4311	337					341	return;
4312							}
4313
4314							sub link_subnet {
4315	1251			1251	0	1031	my ($object, $parent) = @_;
4316
4317							my $context = sub {
4318	1	50 50		1		7	!$parent ? $object->{name}
4319							: ref $parent ? "$object->{name} of $parent->{name}"
4320							: "$parent $object->{name}";
4321	1251					2705	};
4322	1251	100				4258	return if not $object->{subnet_of};
4323	36 36					38 66	my ($type, $name) = @{ $object->{subnet_of} };
4324	36	50				81	if ($type ne 'network') {
4325	0					0	err_msg "Attribute 'subnet_of' of ", $context->(), "\n",
4326							" must not be linked to $type:$name";
4327
4328							# Prevent further errors;
4329	0					0	delete $object->{subnet_of};
4330	0					0	return;
4331							}
4332	36					49	my $network = $networks{$name};
4333	36	50				69	if (not $network) {
4334	0					0	warn_msg("Ignoring undefined network:$name",
4335							" from attribute 'subnet_of'\n of ", $context->());
4336
4337							# Prevent further errors;
4338	0					0	delete $object->{subnet_of};
4339	0					0	return;
4340							}
4341	36					40	$object->{subnet_of} = $network;
4342	36					56	my $ip = $network->{ip};
4343	36					33	my $mask = $network->{mask};
4344	36					44	my $sub_ip = $object->{ip};
4345
4346							# debug($network->{name}) if not defined $ip;
4347	36	50				71	if ($ip eq 'unnumbered') {
4348	0					0	err_msg "Unnumbered $network->{name} must not be referenced from",
4349							" attribute 'subnet_of'\n of ", $context->();
4350
4351							# Prevent further errors;
4352	0					0	delete $object->{subnet_of};
4353	0					0	return;
4354							}
4355
4356							# $sub_mask needs not to be tested here,
4357							# because it has already been checked for $object.
4358	36	100				53	if (not(match_ip($sub_ip, $ip, $mask))) {
4359	1					2	err_msg $context->(), " is subnet_of $network->{name}",
4360							" but its IP doesn't match that's IP/mask";
4361							}
4362	36					117	return;
4363							}
4364
4365							sub link_subnets {
4366	337			337	0	495	for my $network (values %networks) {
4367	1115					1285	link_subnet($network, undef);
4368							}
4369	337					637	for my $obj (values %networks, values %aggregates, values %areas) {
4370	1233	100				2036	my $nat = $obj->{nat} or next;
4371	106 106					92 162	for my $nat (values %{ $obj->{nat} }) {
4372	136					150	link_subnet($nat, $obj);
4373							}
4374							}
4375	337					332	return;
4376							}
4377
4378							my @pathrestrictions;
4379
4380							sub add_pathrestriction {
4381	28			28	0	31	my ($name, $elements) = @_;
4382	28					34	my $restrict = new('Pathrestriction', name => $name, elements => $elements);
4383	28					32	for my $interface (@$elements) {
4384							# debug("pathrestriction $name at $interface->{name}");
4385	59 59					42 80	push @{ $interface->{path_restrict} }, $restrict;
4386	59					55	my $router = $interface->{router};
4387	59	100				110	$router->{managed} or $router->{semi_managed} = 1;
4388							}
4389	28					30	push @pathrestrictions, $restrict;
4390	28					29	return;
4391							}
4392
4393							sub link_pathrestrictions {
4394	337			337	0	530	for my $restrict (values %pathrestrictions) {
4395	29					57	$restrict->{elements} = expand_group $restrict->{elements},
4396							$restrict->{name};
4397	29					50	my $changed;
4398	29					30	my $private = my $no_private = $restrict->{private};
4399	29 29					29 37	for my $obj (@{ $restrict->{elements} }) {
4400	60	50				77	if (not is_interface($obj)) {
4401	0					0	err_msg("$restrict->{name} must not reference $obj->{name}");
4402	0					0	$obj = undef;
4403	0					0	$changed = 1;
4404	0					0	next;
4405							}
4406
4407							# Add pathrestriction to interface.
4408							# Multiple restrictions may be applied to a single
4409							# interface.
4410	60 60					51 86	push @{ $obj->{path_restrict} }, $restrict;
4411
4412							# Unmanaged router with pathrestriction is handled specially.
4413							# It is separating zones, but gets no code.
4414	60					55	my $router = $obj->{router};
4415	60	100				97	$router->{managed} or $router->{semi_managed} = 1;
4416
4417							# Pathrestrictions must not be applied to secondary interfaces
4418	60	50				87	$obj->{main_interface}
4419							and err_msg "secondary $obj->{name} must not be used",
4420							" in pathrestriction";
4421
4422							# Private pathrestriction must reference at least one interface
4423							# of its own context.
4424	60	50				67	if ($private) {
4425	0	0				0	if (my $obj_p = $obj->{private}) {
4426	0	0				0	$private eq $obj_p and $no_private = 0;
4427							}
4428							}
4429
4430							# Public pathrestriction must not reference private interface.
4431							else {
4432	60	50				119	if (my $obj_p = $obj->{private}) {
4433	0					0	err_msg "Public $restrict->{name} must not reference",
4434							" $obj_p.private $obj->{name}";
4435							}
4436							}
4437							}
4438	29	50				45	if ($no_private) {
4439	0					0	err_msg "$private.private $restrict->{name} must reference",
4440							" at least one interface out of $private.private";
4441							}
4442	29	50				45	if ($changed) {
4443	0 0 0					0 0 0	$restrict->{elements} = [ grep { $_ } @{ $restrict->{elements} } ];
4444							}
4445	29 29					23 43	my $count = @{ $restrict->{elements} };
4446	29	50 50				64	if ($count == 1) {
4447	0					0	warn_msg("Ignoring $restrict->{name} with only",
4448							" $restrict->{elements}->[0]->{name}");
4449	0					0	$restrict->{elements} = [];
4450							}
4451							elsif ($count == 0) {
4452	0					0	warn_msg("Ignoring $restrict->{name} without elements");
4453							}
4454
4455							# Add pathrestriction to tunnel interfaces,
4456							# which belong to real interface.
4457							# Don't count them as extra elements.
4458	29 29					26 40	for my $interface (@{ $restrict->{elements} }) {
4459	60	50	33			231	next if not($interface->{spoke} or $interface->{hub});
4460
4461							# Don't add for no_check interface because traffic would
4462							# pass the pathrestriction two times.
4463	0	0				0	next if $interface->{no_check};
4464	0					0	my $router = $interface->{router};
4465	0 0					0 0	for my $intf (@{ $router->{interfaces} }) {
4466	0					0	my $real_intf = $intf->{real_interface};
4467	0	0				0	next if not $real_intf;
4468	0	0				0	next if not $real_intf eq $interface;
4469
4470							# debug("Adding $restrict->{name} to $intf->{name}");
4471	0 0					0 0	push @{ $restrict->{elements} }, $intf;
4472	0 0					0 0	push @{ $intf->{path_restrict} }, $restrict;
4473							}
4474							}
4475							}
4476	337					307	return;
4477							}
4478
4479							# Collect groups of virtual interfaces
4480							# - be connected to the same network and
4481							# - having the same IP address.
4482							# Link all virtual interfaces to the group of member interfaces.
4483							# Check consistency:
4484							# - Member interfaces must use identical protocol and identical ID.
4485							# - The same ID must not be used by some other group
4486							# - connected to the same network
4487							# - emploing the same redundancy type
4488							sub link_virtual_interfaces {
4489
4490							# Collect array of virtual interfaces with same IP at same network.
4491	337			337	0	291	my %net2ip2virtual;
4492
4493							# Hash table to look up first virtual interface of a group
4494							# inside the same network and using the same ID and type.
4495							my %net2id2type2virtual;
4496	337					404	for my $virtual1 (@virtual_interfaces) {
4497	72	50				110	next if $virtual1->{disabled};
4498	72					68	my $ip = $virtual1->{ip};
4499	72					67	my $net = $virtual1->{network};
4500	72		100			171	my $type1 = $virtual1->{redundancy_type} \|\| '';
4501	72		50			173	my $id1 = $virtual1->{redundancy_id} \|\| '';
4502	72	100				162	if (my $interfaces = $net2ip2virtual{$net}->{$ip}) {
4503	37					33	my $virtual2 = $interfaces->[0];
4504	37		100			88	my $type2 = $virtual2->{redundancy_type} \|\| '';
4505	37	50				53	if ($type1 ne $type2) {
4506	0					0	err_msg "Virtual IP: $virtual1->{name} and $virtual2->{name}",
4507							" use different redundancy protocols";
4508	0					0	next;
4509							}
4510	37	50	50			119	if (not $id1 eq ($virtual2->{redundancy_id} \|\| '')) {
4511	0					0	err_msg "Virtual IP: $virtual1->{name} and $virtual2->{name}",
4512							" use different ID";
4513	0					0	next;
4514							}
4515
4516							# This changes value of %net2ip2virtual and all attributes
4517							# {redundancy_interfaces} where this array is referenced.
4518	37					39	push @$interfaces, $virtual1;
4519	37					71	$virtual1->{redundancy_interfaces} = $interfaces;
4520							}
4521							else {
4522	35					83	$net2ip2virtual{$net}->{$ip} = $virtual1->{redundancy_interfaces} =
4523							[$virtual1];
4524
4525							# Check for identical ID used at unrelated virtual interfaces
4526							# inside the same network.
4527	35	50				81	if ($id1) {
4528	0	0				0	if (my $virtual2 =
4529							$net2id2type2virtual{$net}->{$id1}->{$type1})
4530							{
4531	0					0	err_msg "Virtual IP:",
4532							" Unrelated $virtual1->{name} and $virtual2->{name}",
4533							" use identical ID";
4534							}
4535							else {
4536	0					0	$net2id2type2virtual{$net}->{$id1}->{$type1} = $virtual1;
4537							}
4538							}
4539							}
4540							}
4541
4542
4543							# A virtual interface is used as hop for static routing.
4544							# Therefore a network behind this interface must be reachable
4545							# via all virtual interfaces of the group.
4546							# This can only be guaranteed, if pathrestrictions are identical
4547							# at all interfaces.
4548							# Exception in routing code:
4549							# If the group has ony two interfaces, the one or other physical
4550							# interface can be used as hop.
4551	337					306	my %seen;
4552	337					516	for my $href (values %net2ip2virtual) {
4553	35					54	for my $interfaces (values %$href) {
4554	35	100				85	next if @$interfaces <= 2;
4555	4 14					7 19	my @virt_routers = map { $_->{router} } @$interfaces;
4556	4 14					6 27	my %routers_hash = map { $_ => $_ } @virt_routers;
4557	4					6	for my $router (@virt_routers) {
4558	14 14					12 16	for my $interface (@{ $router->{interfaces} }) {
4559	55	100				89	next if $interface->{main_interface};
4560	33	100				54	my $restricts = $interface->{path_restrict} or next;
4561	2					2	for my $restrict (@$restricts) {
4562	2	100				6	next if $seen{$restrict};
4563	2					4	my @restrict_routers =
4564	2					3	grep({ $routers_hash{$_} }
4565	1					2	map { $_->{router} }
4566	1					1	@{ $restrict->{elements} });
4567	1	50				2	next if @restrict_routers == @virt_routers;
4568	1					3	$seen{$restrict} = 1;
4569	1					1	my @info;
4570	1					1	for my $router (@virt_routers) {
4571	3					3	my $info = $router->{name};
4572	3 6	100				2 15	if (grep { $_ eq $router} @restrict_routers) {
4573	1					2	$info .= " has $restrict->{name}";
4574							}
4575	3					4	push @info, $info;
4576							}
4577	1					4	err_msg("Must apply pathrestriction equally to",
4578							" group of routers with virtual IP:\n",
4579							" - ",
4580							join("\n - ", @info));
4581							}
4582							}
4583							}
4584							}
4585							}
4586
4587							# Automatically add pathrestriction to interfaces belonging to
4588							# $net2ip2virtual, if at least one interface is managed.
4589							# Pathrestriction would be useless if all devices are unmanaged.
4590	337					494	for my $href (values %net2ip2virtual) {
4591	35					39	for my $interfaces (values %$href) {
4592	35					35	for my $interface (@$interfaces) {
4593	42					38	my $router = $interface->{router};
4594	42	100	67			127	if ($router->{managed} \|\| $router->{routing_only}) {
4595	28					46	my $name = "auto-virtual-" . print_ip $interface->{ip};
4596	28					45	add_pathrestriction($name, $interfaces);
4597	28					57	last;
4598							}
4599							}
4600							}
4601							}
4602	337					514	return;
4603							}
4604
4605							sub check_ip_addresses {
4606	337			337	0	500	for my $network (values %networks) {
4607	1115 11	50	50			2354 29	if ( $network->{ip} eq 'unnumbered'
4608							and $network->{interfaces}
4609							and @{ $network->{interfaces} } > 2)
4610							{
4611	0					0	my $msg = "Unnumbered $network->{name} is connected to"
4612							. " more than two interfaces:";
4613	0 0					0 0	for my $interface (@{ $network->{interfaces} }) {
4614	0					0	$msg .= "\n $interface->{name}";
4615							}
4616	0					0	err_msg($msg);
4617							}
4618
4619	1115					835	my %ip2obj;
4620
4621							# 1. Check for duplicate interface addresses.
4622							# 2. Short interfaces must not be used, if a managed interface
4623							# with static routing exists in the same network.
4624	1115					801	my ($short_intf, $route_intf);
4625	1115 1115					835 1362	for my $interface (@{ $network->{interfaces} }) {
4626	1633					1545	my $ip = $interface->{ip};
4627	1633	100				1872	if ($ip eq 'short') {
4628
4629							# Ignore short interface from splitted crypto router.
4630	223 223	100				179 413	if (1 < @{ $interface->{router}->{interfaces} }) {
4631	208					183	$short_intf = $interface;
4632							}
4633							}
4634							else {
4635	1410	100				2724	unless ($ip =~ /^(?:unnumbered\|negotiated\|tunnel\|bridged)$/) {
4636	1330					1137	my $router = $interface->{router};
4637	1330	100	100			4772	if (($router->{managed} \|\| $router->{routing_only})
4638							&& !$interface->{routing})
4639							{
4640	713					606	$route_intf = $interface;
4641							}
4642	1330	100				1750	if (my $old_intf = $ip2obj{$ip}) {
4643	39	100	67			140	unless ($old_intf->{redundant}
4644							and $interface->{redundant})
4645							{
4646	2					9	err_msg "Duplicate IP address for",
4647							" $old_intf->{name} and $interface->{name}";
4648							}
4649							}
4650							else {
4651	1291					1887	$ip2obj{$ip} = $interface;
4652							}
4653							}
4654							}
4655	1633	100	100			3748	if ($short_intf and $route_intf) {
4656	1					6	err_msg "$short_intf->{name} must be defined in more detail,",
4657							" since there is\n",
4658							" a managed $route_intf->{name} with static routing enabled.";
4659							}
4660							}
4661	1115					1022	my %range2obj;
4662	1115 1115					795 1427	for my $host (@{ $network->{hosts} }) {
4663	181	100 50				331	if (my $ip = $host->{ip}) {
4664	160	100				272	if (my $other_device = $ip2obj{$ip}) {
4665	4					15	err_msg "Duplicate IP address for $other_device->{name}",
4666							" and $host->{name}";
4667							}
4668							else {
4669	156					288	$ip2obj{$ip} = $host;
4670							}
4671							}
4672							elsif (my $range = $host->{range}) {
4673	21					24	my ($from, $to) = @$range;
4674	21	100				57	if (my $other_device = $range2obj{$from}->{$to}) {
4675	1					4	err_msg "Duplicate IP range for $other_device->{name}",
4676							" and $host->{name}";
4677							}
4678							else {
4679	20					41	$range2obj{$from}->{$to} = $host;
4680							}
4681							}
4682							}
4683	1115 1115					878 2075	for my $host (@{ $network->{hosts} }) {
4684	181	100				535	if (my $range = $host->{range}) {
4685	21					39	for (my $ip = $range->[0] ; $ip <= $range->[1] ; $ip++) {
4686	774	100				1615	if (my $other_device = $ip2obj{$ip}) {
4687	5	100				6	is_host($other_device)
4688							or err_msg("Duplicate IP address for",
4689							" $other_device->{name}",
4690							" and $host->{name}");
4691							}
4692							}
4693							}
4694							}
4695							}
4696	337					357	return;
4697							}
4698
4699							sub link_ipsec;
4700							sub link_crypto;
4701							sub link_tunnels;
4702
4703							sub link_topology {
4704	337			337	0	474	progress('Linking topology');
4705	337					465	link_routers;
4706	337					487	link_ipsec;
4707	337					459	link_crypto;
4708	337					455	link_tunnels;
4709	337					476	link_pathrestrictions;
4710	337					435	link_virtual_interfaces;
4711	337					452	link_areas;
4712	337					445	link_subnets;
4713	337					478	link_owners;
4714	337					439	check_ip_addresses();
4715	337					302	return;
4716							}
4717
4718							####################################################################
4719							# Mark all parts of the topology located behind disabled interfaces.
4720							# "Behind" is defined like this:
4721							# Look from a router to its interfaces;
4722							# if an interface is marked as disabled,
4723							# recursively mark the whole part of the topology located behind
4724							# this interface as disabled.
4725							# Be cautious with loops:
4726							# Mark all interfaces at loop entry as disabled,
4727							# otherwise the whole topology will get disabled.
4728							####################################################################
4729
4730							sub disable_behind;
4731
4732							sub disable_behind {
4733	3			3	0	3	my ($in_interface) = @_;
4734
4735							# debug("disable_behind $in_interface->{name}");
4736	3					5	$in_interface->{disabled} = 1;
4737	3					2	my $network = $in_interface->{network};
4738	3	100	67			13	if (not $network or $network->{disabled}) {
4739
4740							# debug("Stop disabling at $network->{name}");
4741	1					2	return;
4742							}
4743	2					3	$network->{disabled} = 1;
4744	2 2					3 3	for my $host (@{ $network->{hosts} }) {
4745	1					2	$host->{disabled} = 1;
4746							}
4747	2 2					2 4	for my $interface (@{ $network->{interfaces} }) {
4748	3	100				8	next if $interface eq $in_interface;
4749
4750							# This stops at other entry of a loop as well.
4751	1	50				2	if ($interface->{disabled}) {
4752
4753							# debug("Stop disabling at $interface->{name}");
4754	1					2	next;
4755							}
4756	0					0	$interface->{disabled} = 1;
4757	0					0	my $router = $interface->{router};
4758	0					0	$router->{disabled} = 1;
4759	0 0					0 0	for my $out_interface (@{ $router->{interfaces} }) {
4760	0	0				0	next if $out_interface eq $interface;
4761	0					0	disable_behind $out_interface ;
4762							}
4763							}
4764	2					3	return;
4765							}
4766
4767							# Lists of network objects which are left over after disabling.
4768							#my @managed_routers; # defined above
4769							my @routing_only_routers;
4770							my @managed_crypto_hubs;
4771							my @routers;
4772							my @networks;
4773							my @zones;
4774							my @areas;
4775
4776							# Group bridged networks by prefix of name.
4777							# Each group
4778							# - must have the same IP address and mask,
4779							# - must have at least two members,
4780							# - must be adjacent
4781							# - linked by bridged interfaces
4782							# - IP addresses of hosts must be disjoint (ToDo).
4783							# Each router having a bridged interface
4784							# must connect at least two bridged networks of the same group.
4785							sub check_bridged_networks {
4786	337			337	0	290	my %prefix2net;
4787	337					366	for my $network (@networks) {
4788	1112	100				1902	my $prefix = $network->{bridged} or next;
4789	14					32	$prefix2net{$prefix}->{$network} = $network;
4790							}
4791	337					593	for my $prefix (keys %prefix2net) {
4792	7	50				20	if (my $network = $networks{$prefix}) {
4793	0	0				0	$network->{disabled}
4794							or err_msg("Must not define $network->{name} together with",
4795							" bridged networks of same name");
4796							}
4797							}
4798	337					499	for my $href (values %prefix2net) {
4799	7					13	my @group = values %$href;
4800	7					8	my $net1 = pop(@group);
4801	7	50				11	@group or warn_msg("Bridged $net1->{name} must not be used solitary");
4802	7					8	my %seen;
4803	7					8	my @next = ($net1);
4804	7 7					6 14	my ($ip1, $mask1) = @{$net1}{qw(ip mask)};
4805
4806							# Mark all networks connected directly or indirectly with $net1
4807							# by a bridge as 'connected' in $href.
4808	7					14	while (my $network = pop(@next)) {
4809	14 14					14 17	my ($ip, $mask) = @{$network}{qw(ip mask)};
4810	14	50	33			46	$ip == $ip1 and $mask == $mask1
4811							or err_msg("$net1->{name} and $network->{name} must have",
4812							" identical ip/mask");
4813	14					23	$href->{$network} = 'connected';
4814	14 14					9 18	for my $in_intf (@{ $network->{interfaces} }) {
4815	24	100				54	next if $in_intf->{ip} ne 'bridged';
4816	14					13	my $router = $in_intf->{router};
4817	14	100				39	next if $seen{$router};
4818	7					4	my $count = 1;
4819	7					12	$seen{$router} = $router;
4820	7	50				13	if (my $layer3_intf = $in_intf->{layer3_interface}) {
4821	7	50				14	match_ip($layer3_intf->{ip}, $ip, $mask)
4822							or err_msg("$layer3_intf->{name}'s IP doesn't match",
4823							" IP/mask of bridged networks");
4824							}
4825	7 7					7 12	for my $out_intf (@{ $router->{interfaces} }) {
4826	21	100				41	next if $out_intf eq $in_intf;
4827	14	100				26	next if $out_intf->{ip} ne 'bridged';
4828	7					9	my $next_net = $out_intf->{network};
4829	7	50				13	next if not $href->{$next_net};
4830	7					7	push(@next, $out_intf->{network});
4831	7					14	$count++;
4832							}
4833	7	50				23	$count > 1
4834							or err_msg("$router->{name} can't bridge a single network");
4835							}
4836							}
4837	7					7	for my $network (@group) {
4838	7	50				31	$href->{$network} eq 'connected'
4839							or err_msg(
4840							"$network->{name} and $net1->{name}",
4841							" must be connected by bridge"
4842							);
4843							}
4844							}
4845	337					434	return;
4846							}
4847
4848							sub mark_disabled {
4849	337 1585			337	0	560 1749	my @disabled_interfaces = grep { $_->{disabled} } values %interfaces;
4850
4851	337					417	for my $interface (@disabled_interfaces) {
4852	3	50				7	next if $interface->{router}->{disabled};
4853	3					6	disable_behind($interface);
4854	3	50				8	if ($interface->{router}->{disabled}) {
4855
4856							# We reached an initial element of @disabled_interfaces,
4857							# which seems to be part of a loop.
4858							# This is dangerous, since the whole topology
4859							# may be disabled by accident.
4860	0					0	err_msg "$interface->{name} must not be disabled,\n",
4861							" since it is part of a loop";
4862							}
4863							}
4864	337					401	for my $interface (@disabled_interfaces) {
4865
4866							# Delete disabled interfaces from routers.
4867	3					4	my $router = $interface->{router};
4868	3					5	aref_delete($router->{interfaces}, $interface);
4869	3	50	33			8	if ($router->{managed} \|\| $router->{routing_only}) {
4870	3					5	aref_delete($interface->{hardware}->{interfaces}, $interface);
4871							}
4872							}
4873
4874							# Disable area, where all interfaces or anchor are disabled.
4875	337					790	for my $area (sort by_name values %areas) {
4876	66					61	my $ok;
4877	66	100				116	if (my $anchor = $area->{anchor}) {
4878	17					23	$ok = !$anchor->{disabled};
4879							}
4880							else {
4881	49					58	for my $attr (qw(border inclusive_border)) {
4882	98	100				206	my $borders = $area->{$attr} or next;
4883	52 62	50				70 163	if (my @active_borders = grep { !$_->{disabled} } @$borders) {
4884	52					65	$area->{$attr} = \@active_borders;
4885	52					75	$ok = 1;
4886							}
4887							}
4888							}
4889	66	50				108	if ($ok) {
4890	66					109	push @areas, $area;
4891							}
4892							else {
4893	0					0	$area->{disabled} = 1;
4894							}
4895							}
4896
4897	337					735	for my $router (sort(by_name values %routers), @router_fragments) {
4898	690	50				1080	next if $router->{disabled};
4899	690					602	push @routers, $router;
4900	690	100 100				1152	if ($router->{managed}) {
4901	465					581	push @managed_routers, $router;
4902							}
4903							elsif ($router->{routing_only}) {
4904	6					8	push @routing_only_routers, $router;
4905							}
4906							}
4907
4908							# Collect vrf instances belonging to one device.
4909							# This includes different managed hosts with identical server_name.
4910	337					318	my %name2vrf;
4911	337					395	for my $router (@managed_routers, @routing_only_routers) {
4912	491	100				751	next if $router->{orig_router};
4913	473					497	my $device_name = $router->{device_name};
4914	473 473					351 1026	push @{ $name2vrf{$device_name} }, $router;
4915							}
4916	337					507	for my $aref (values %name2vrf) {
4917	469	100				899	next if @$aref == 1;
4918	4 8	50 50	67			5 34	equal(map { $_->{managed} \|\| $_->{routing_only}
4919							? $_->{model}->{name}
4920							: () }
4921							@$aref)
4922							or err_msg("All VRF instances of router:$aref->[0]->{device_name}",
4923							" must have identical model");
4924
4925	4					7	my %hardware;
4926	4					5	for my $router (@$aref) {
4927	8 8					6 11	for my $hardware (@{ $router->{hardware} }) {
4928	14					17	my $name = $hardware->{name};
4929	14	50				19	if (my $other = $hardware{$name}) {
4930	0					0	err_msg(
4931							"Duplicate hardware '$name' at",
4932							" $other->{name} and $router->{name}"
4933							);
4934							}
4935							else {
4936	14					28	$hardware{$name} = $router;
4937							}
4938							}
4939							}
4940	4					6	my $shared_hash = {};
4941	4					8	for my $router (@$aref) {
4942	8					9	$router->{vrf_members} = $aref;
4943	8					16	$router->{vrf_shared_data} = $shared_hash;
4944							}
4945							}
4946
4947							# Collect networks into @networks.
4948							# We need a deterministic order.
4949							# Don't sort by name because code shouldn't change if a network is renamed.
4950							# Derive order from order of routers and interfaces.
4951	337					304	my %seen;
4952	337					353	for my $router (@routers) {
4953	690 690					530 848	for my $interface (@{ $router->{interfaces} }) {
4954	1610	50				2175	next if $interface->{disabled};
4955	1610					1323	my $network = $interface->{network};
4956	1610	100				4425	$seen{$network}++ or push @networks, $network;
4957							}
4958							}
4959
4960							# Find networks not connected to any router.
4961	337					533	for my $network (values %networks) {
4962	1115	100				1508	next if $network->{disabled};
4963	1113	100				2180	if (! $seen{$network}) {
4964	20	100				36	if (keys %networks > 1) {
4965	1					3	err_msg("$network->{name} isn't connected to any router");
4966	1					3	$network->{disabled} = 1;
4967							}
4968							else {
4969	19					35	push @networks, $network;
4970							}
4971							}
4972							}
4973
4974	337 72					446 112	@virtual_interfaces = grep { not $_->{disabled} } @virtual_interfaces;
4975	337					476	check_bridged_networks();
4976	337					702	return;
4977							}
4978
4979							####################################################################
4980							# Convert hosts to subnets.
4981							# Find adjacent subnets.
4982							# Mark subnet relation of subnets.
4983							####################################################################
4984
4985							# 255.255.255.255, 127.255.255.255, ..., 0.0.0.3, 0.0.0.1, 0.0.0.0
4986							my @inverse_masks = map { complement_32bit prefix2mask $_ } (0 .. 32);
4987
4988							# Convert an IP range to a set of covering IP/mask pairs.
4989							sub split_ip_range {
4990	21			21	0	20	my ($low, $high) = @_;
4991	21					19	my @result;
4992							IP:
4993	21					34	while ($low <= $high) {
4994	39					41	for my $mask (@inverse_masks) {
4995	1200	100	100			1916	if (($low & $mask) == 0 && ($low + $mask) <= $high) {
4996	39					51	push @result, [ $low, complement_32bit $mask ];
4997	39					37	$low = $low + $mask + 1;
4998	39					72	next IP;
4999							}
5000							}
5001							}
5002	21					35	return @result;
5003							}
5004
5005							sub convert_hosts {
5006	321			321	0	415	progress('Converting hosts to subnets');
5007	321					361	for my $network (@networks) {
5008	1180	100				2506	next if $network->{ip} =~ /^(?:unnumbered\|tunnel)$/;
5009	1147					819	my @inv_prefix_aref;
5010
5011							# Converts hosts and ranges to subnets.
5012							# Eliminate duplicate subnets.
5013	1147 1147					858 1496	for my $host (@{ $network->{hosts} }) {
5014	174					313	my ($name, $nat, $id, $private, $owner) =
5015	174					184	@{$host}{qw(name nat id private owner)};
5016	174					159	my @ip_mask;
5017	174	100 50				312	if (my $ip = $host->{ip}) {
5018	153					246	@ip_mask = [ $ip, 0xffffffff ];
5019	153	100				264	if ($id) {
5020	15	100				78	if (my ($user, $dom) = ($id =~ /^(.?)(\@.)$/)) {
5021	14	100				36	$user or err_msg("ID of $name must not start",
5022							" with character '\@'");
5023							}
5024							else {
5025	1					3	err_msg("ID of $name must contain character '\@'");
5026							}
5027							}
5028							}
5029							elsif ($host->{range}) {
5030	21 21					21 28	my ($ip1, $ip2) = @{ $host->{range} };
5031	21					36	@ip_mask = split_ip_range $ip1, $ip2;
5032	21	100				39	if ($id) {
5033	11	100 100 100				40	if (@ip_mask > 1) {
5034	1					4	err_msg("Range of $name with ID must expand to",
5035							" exactly one subnet");
5036							}
5037							elsif ($ip_mask[0]->[1] == 0xffffffff) {
5038	1					3	err_msg("$name with ID must not have single IP");
5039							}
5040							elsif ($id =~ /^.+\@/) {
5041	1					3	err_msg("ID of $name must start with character '\@'",
5042							" or have no '\@' at all");
5043							}
5044							}
5045							}
5046							else {
5047	0					0	internal_err("unexpected host type");
5048							}
5049	174					199	for my $ip_mask (@ip_mask) {
5050	192					213	my ($ip, $mask) = @$ip_mask;
5051	192					257	my $inv_prefix = 32 - mask2prefix $mask;
5052	192	100				417	if (my $other_subnet = $inv_prefix_aref[$inv_prefix]->{$ip}) {
5053	4					7	my $nat2 = $other_subnet->{nat};
5054	4					2	my $nat_error;
5055	4	50 50	33 25			33	if ($nat xor $nat2) {
5056	0					0	$nat_error = 1;
5057							}
5058							elsif ($nat and $nat2) {
5059
5060							# Number of entries is equal.
5061	0	0				0	if (keys %$nat == keys %$nat2) {
5062
5063							# Entries are equal.
5064	0					0	for my $name (keys %$nat) {
5065	0	0	0			0	unless ($nat2->{$name}
5066							and $nat->{$name} eq $nat2->{$name})
5067							{
5068	0					0	$nat_error = 1;
5069	0					0	last;
5070							}
5071							}
5072							}
5073							else {
5074	0					0	$nat_error = 1;
5075							}
5076							}
5077							$nat_error
5078	4	50				7	and err_msg "Inconsistent NAT definition for",
5079							" $other_subnet->{name} and $host->{name}";
5080
5081	4					4	my $owner2 = $other_subnet->{owner};
5082	4	0	33 12			21	if (($owner xor $owner2)
5083							\|\| $owner && $owner2 && $owner ne $owner2)
5084							{
5085	0					0	err_msg "Inconsistent owner definition for",
5086							" $other_subnet->{name} and $host->{name}";
5087							}
5088	4 4					3 15	push @{ $host->{subnets} }, $other_subnet;
5089							}
5090							else {
5091	188					287	my $subnet = new(
5092							'Subnet',
5093							name => $name,
5094							network => $network,
5095							ip => $ip,
5096							mask => $mask,
5097							);
5098	188	100				301	$subnet->{nat} = $nat if $nat;
5099	188	50				266	$subnet->{private} = $private if $private;
5100	188	100				274	$subnet->{owner} = $owner if $owner;
5101	188	100				260	if ($id) {
5102	30					32	$subnet->{id} = $id;
5103	30					37	$subnet->{radius_attributes} =
5104							$host->{radius_attributes};
5105							}
5106	188					264	$inv_prefix_aref[$inv_prefix]->{$ip} = $subnet;
5107	188 188					151 288	push @{ $host->{subnets} }, $subnet;
5108	188 188					162 594	push @{ $network->{subnets} }, $subnet;
5109							}
5110							}
5111							}
5112
5113							# Find adjacent subnets which build a larger subnet.
5114	1147					1563	my $network_inv_prefix = 32 - mask2prefix $network->{mask};
5115	1147					1981	for (my $i = 0 ; $i < @inv_prefix_aref ; $i++) {
5116	189	100				346	if (my $ip2subnet = $inv_prefix_aref[$i]) {
5117	163					205	my $next = 2**$i;
5118	163					225	my $modulo = 2 * $next;
5119	163					306	for my $ip (keys %$ip2subnet) {
5120	196					189	my $subnet = $ip2subnet->{$ip};
5121
5122	196	100	100 100			1100	if (
5123
5124							# Don't combine subnets with NAT
5125							# ToDo: This would be possible if all NAT addresses
5126							# match too.
5127							# But, attention for PIX firewalls:
5128							# static commands for networks / subnets block
5129							# network and broadcast address.
5130							not $subnet->{nat}
5131
5132							# Don't combine subnets having radius-ID.
5133							and not $subnet->{id}
5134
5135							# Only take the left part of two adjacent subnets.
5136							and $ip % $modulo == 0
5137							)
5138							{
5139	101					101	my $next_ip = $ip + $next;
5140
5141							# Find the right part.
5142	101	100				216	if (my $neighbor = $ip2subnet->{$next_ip}) {
5143	8					11	$subnet->{neighbor} = $neighbor;
5144	8					8	my $up_inv_prefix = $i + 1;
5145	8					6	my $up;
5146	8	50 50	67			35	if ($up_inv_prefix >= $network_inv_prefix) {
5147
5148							# Larger subnet is whole network.
5149	0					0	$up = $network;
5150							}
5151							elsif ( $up_inv_prefix < @inv_prefix_aref
5152							and $up =
5153							$inv_prefix_aref[$up_inv_prefix]->{$ip})
5154							{
5155							}
5156							else {
5157	8					41	(my $name = $subnet->{name}) =~
5158							s/^.*:/auto_subnet:/;
5159	8					17	my $mask = prefix2mask(32 - $up_inv_prefix);
5160	8					74	$up = new(
5161							'Subnet',
5162							name => $name,
5163							network => $network,
5164							ip => $ip,
5165							mask => $mask
5166							);
5167	8	50				18	if (my $private = $subnet->{private}) {
5168	0	0				0	$up->{private} = $private if $private;
5169							}
5170	8					16	$inv_prefix_aref[$up_inv_prefix]->{$ip} = $up;
5171							}
5172	8					9	$subnet->{up} = $up;
5173	8					8	$neighbor->{up} = $up;
5174	8 8					9 11	push @{ $network->{subnets} }, $up;
5175
5176							# Don't search for enclosing subnet below.
5177	8					15	next;
5178							}
5179							}
5180
5181							# For neighbors, {up} has been set already.
5182	188	100				299	next if $subnet->{up};
5183
5184							# Search for enclosing subnet.
5185	183					370	for (my $j = $i + 1 ; $j < @inv_prefix_aref ; $j++) {
5186	52					63	my $mask = prefix2mask(32 - $j);
5187	52					56	$ip = $ip & $mask; # Perl bug #108480
5188	52	100				129	if (my $up = $inv_prefix_aref[$j]->{$ip}) {
5189	7					9	$subnet->{up} = $up;
5190	7					6	last;
5191							}
5192							}
5193
5194							# Use network, if no enclosing subnet found.
5195	183		67			862	$subnet->{up} \|\|= $network;
5196							}
5197							}
5198							}
5199
5200							# Attribute {up} has been set for all subnets now.
5201							# Do the same for interfaces.
5202	1147 1147					892 1497	for my $interface (@{ $network->{interfaces} }) {
5203	1497					2759	$interface->{up} = $network;
5204							}
5205							}
5206	321					351	return;
5207							}
5208
5209							# Find adjacent subnets and substitute them by their enclosing subnet.
5210							sub combine_subnets {
5211	596			596	0	526	my ($subnets) = @_;
5212	596 102					729 245	my %hash = map { $_ => $_ } @$subnets;
5213	596					447	my @extra;
5214	596					459	while(1) {
5215	600					667	for my $subnet (@$subnets) {
5216	148					98	my $neighbor;
5217	148	100	100			390	if ($neighbor = $subnet->{neighbor} and $hash{$neighbor}) {
5218	5					3	my $up = $subnet->{up};
5219	5	50				10	unless ($hash{$up}) {
5220	5					6	$hash{$up} = $up;
5221	5					6	push @extra, $up;
5222							}
5223	5					6	delete $hash{$subnet};
5224	5					8	delete $hash{$neighbor};
5225							}
5226							}
5227	600	100				749	if (@extra) {
5228
5229							# Try again to combine subnets with extra subnets.
5230							# This version isn't optimized.
5231	4					7	push @$subnets, @extra;
5232	4					4	@extra = ();
5233							}
5234							else {
5235	596					542	last;
5236							}
5237							}
5238
5239							# Sort networks by size of mask,
5240							# i.e. large subnets coming first and
5241							# for equal mask by IP address.
5242							# We need this to make the output deterministic.
5243	596 23	50				1277 133	return [ sort { $a->{mask} <=> $b->{mask} \|\| $a->{ip} <=> $b->{ip} }
5244							values %hash ];
5245							}
5246
5247							####################################################################
5248							# Expand rules
5249							#
5250							# Simplify rules to expanded rules where each rule has exactly one
5251							# src, dst and prt
5252							####################################################################
5253
5254							my %name2object = (
5255							host => \%hosts,
5256							network => \%networks,
5257							interface => \%interfaces,
5258							any => \%aggregates,
5259							group => \%groups,
5260							area => \%areas,
5261							);
5262
5263							sub get_intf {
5264	71			71	0	65	my ($router) = @_;
5265	71	50 100				165	if (my $orig_router = $router->{orig_router}) {
5266	0 0					0 0	return @{ $orig_router->{orig_interfaces} };
5267							}
5268							elsif (my $orig_interfaces = $router->{orig_interfaces}) {
5269	10					21	return @$orig_interfaces;
5270							}
5271							else {
5272	61 61					43 144	return @{ $router->{interfaces} };
5273							}
5274							}
5275
5276							my %auto_interfaces;
5277
5278							sub get_auto_intf {
5279	49			49	0	41	my ($object, $managed) = @_;
5280	49		50			126	$managed \|\|= 0;
5281	49					85	my $result = $auto_interfaces{$object}->{$managed};
5282	49	100				76	if (not $result) {
5283	23					16	my $name;
5284	23	100				27	if (is_router $object) {
5285	17					70	($name = $object->{name}) =~ s/^router://;
5286							}
5287							else {
5288	6					13	$name = "[$object->{name}]";
5289							}
5290	23					55	$name = "interface:$name.[auto]";
5291	23					35	$result = new(
5292							'Autointerface',
5293							name => $name,
5294							object => $object,
5295							managed => $managed
5296							);
5297	23	50				36	$result->{disabled} = 1 if $object->{disabled};
5298	23					46	$auto_interfaces{$object}->{$managed} = $result;
5299
5300							# debug($result->{name});
5301							}
5302	49					109	return $result;
5303							}
5304
5305							# Check intersection of interface and auto-interface.
5306							# Prevent expressions like "interface:r.x &! interface:r.[auto]",
5307							# because we don't know the exact value of the auto-interface.
5308							# The auto-interface could be "r.x" but not for sure.
5309							# $info is hash with attributes
5310							# - i => { $router => $interface, ... }
5311							# - r => { $router => $autointerface, ... }
5312							# - n => { $router => { $network => autointerface, ... }, ... }
5313							#
5314							# interface:router.network conflicts with interface:router.[auto]
5315							# interface:router.network conflicts with interface:[network].[auto]
5316							# interface:router:[auto] conflicts with interface:[network].[auto]
5317							# if router is connected to network.
5318							sub check_auto_intf {
5319	28			28	0	33	my ($info, $elements, $context) = @_;
5320	28					27	my $add_info = {};
5321
5322							# Check current elements with interfaces of previous elements.
5323	28					32	for my $obj (@$elements) {
5324	37					37	my $type = ref $obj;
5325	37					23	my $other;
5326	37	100 100				70	if ($type eq 'Interface') {
5327	10					9	my $router = $obj->{router};
5328	10					10	my $network = $obj->{network};
5329	10		100			42	$other = $info->{r}->{$router} \|\| $info->{n}->{$router}->{$network};
5330	10					21	$add_info->{i}->{$router} = $obj;
5331							}
5332							elsif ($type eq 'Autointerface') {
5333	14					13	my $auto = $obj->{object};
5334	14	100				15	if (is_router($auto)) {
5335	6					5	my $router = $auto;
5336	6					10	$other = $info->{i}->{$router};
5337	6	50				9	if (!$other) {
5338	6					9	my $href = $info->{n}->{$router};
5339	6					13	$other = (values %$href)[0];
5340							}
5341	6					12	$add_info->{r}->{$router} = $obj;
5342							}
5343							else {
5344	8					8	my $network = $auto;
5345	8 8					7 10	for my $interface (@{ $network->{interfaces} }) {
5346	8					7	my $router = $interface->{router};
5347	8					11	$other = $info->{r}->{$router};
5348	8	50	33			32	if (!$other && ($other = $info->{i}->{$router})) {
5349	0	0				0	if (!$other->{network} eq $network) {
5350	0					0	$other = undef;
5351							}
5352							}
5353	8					26	$add_info->{n}->{$router}->{$network} = $obj;
5354							}
5355							}
5356							}
5357	37	100				78	if ($other) {
5358	6					22	err_msg("Must not use $other->{name} and $obj->{name} together\n",
5359							" in intersection of $context");
5360							}
5361							}
5362
5363							# Extend info with values of current elements.
5364	28					51	for my $key (keys %$add_info) {
5365	24					21	my $href = $add_info->{$key};
5366	24					37	for my $rkey (%$href) {
5367	48					46	my $val = $href->{$rkey};
5368	48	100				61	if (ref $val) {
5369	24 24					49 96	@{$info->{$key}->{$rkey}}{keys %$val} = values %$val;
5370							}
5371							else {
5372	24					66	$info->{$key}->{$rkey} = $val;
5373							}
5374							}
5375							}
5376	28					55	return;
5377							}
5378
5379							# Get a reference to an array of network object descriptions and
5380							# return a reference to an array of network objects.
5381							sub expand_group1;
5382
5383							sub expand_group1 {
5384	1763			1763	0	1668	my ($aref, $context, $clean_autogrp) = @_;
5385	1763					1316	my @objects;
5386	1763					1752	for my $parts (@$aref) {
5387
5388	2017					2328	my ($type, $name, $ext) = @$parts;
5389	2017	100 50 100 100 100 50				7158	if ($type eq '&') {
5390	14					13	my @non_compl;
5391							my @compl;
5392	0					0	my %autointf_info;
5393	14					17	for my $element (@$name) {
5394	28	100				40	my $element1 = $element->[0] eq '!' ? $element->[1] : $element;
5395	37					40	my @elements =
5396	37 28					61 95	map { $_->{is_used} = 1; $_; } @{
5397	28					26	expand_group1(
5398							[$element1], "intersection of $context",
5399							$clean_autogrp
5400							)
5401							};
5402	28					54	check_auto_intf(\%autointf_info, \@elements, $context);
5403	28	100				50	if ($element->[0] eq '!') {
5404	13					22	push @compl, @elements;
5405							}
5406							else {
5407	15					23	push @non_compl, \@elements;
5408							}
5409							}
5410	14	50				27	@non_compl >= 1
5411							or err_msg "Intersection needs at least one element",
5412							" which is not complement in $context";
5413	14					14	my $result;
5414	14					16	my $first_set = shift @non_compl;
5415	14					17	for my $element (@$first_set) {
5416	22					45	$result->{$element} = $element;
5417							}
5418	14					17	for my $set (@non_compl) {
5419	1					1	my $intersection;
5420	1					1	for my $element (@$set) {
5421	2	100				5	if ($result->{$element}) {
5422	1					2	$intersection->{$element} = $element;
5423							}
5424							}
5425	1					2	$result = $intersection;
5426							}
5427	14					16	for my $element (@compl) {
5428	13	50				23	next if $element->{disabled};
5429	13	100				48	delete $result->{$element}
5430							or warn_msg("Useless delete of $element->{name} in $context");
5431							}
5432
5433							# Put result into same order as the elements of first non
5434							# complemented set. This set contains all elements of resulting set,
5435							# because we are doing intersection here.
5436	14 22					17 99	push @objects, grep { $result->{$_} } @$first_set;
5437							}
5438							elsif ($type eq '!') {
5439	0					0	err_msg("Complement (!) is only supported as part of intersection",
5440							" in $context");
5441							}
5442							elsif ($type eq 'user') {
5443
5444							# Either a single object or an array of objects.
5445	308					308	my $elements = $name->{elements};
5446	308	50				836	push @objects, ref($elements) eq 'ARRAY' ? @$elements : $elements;
5447							}
5448							elsif ($type eq 'interface') {
5449	266					212	my @check;
5450	266	100 100 50				824	if (ref $name) {
5451	18	50				29	ref $ext
5452							or err_msg("Must not use interface:[..].$ext in $context");
5453	18					20	my ($selector, $managed) = @$ext;
5454	18					101	my $sub_objects = expand_group1 $name,
5455							"interface:[..].[$selector] of $context";
5456	18					27	for my $object (@$sub_objects) {
5457	18	50				29	next if $object->{disabled};
5458	18					19	$object->{is_used} = 1;
5459	18					19	my $type = ref $object;
5460	18	100 50 50 0				31	if ($type eq 'Network') {
5461	12	50				13	if ($selector eq 'all') {
5462	0	0 0				0	if ($object->{is_aggregate}) {
5463
5464							# We can't simply take
5465							# aggregate -> networks -> interfaces,
5466							# because subnets may be missing.
5467	0	0				0	$object->{mask} == 0
5468							or err_msg "Must not use",
5469							" interface:[..].[all]\n",
5470							" with $object->{name} having ip/mask\n",
5471							" in $context";
5472	0 0					0 0	push @check, @{ $object->{zone}->{interfaces} };
5473							}
5474							elsif ($managed) {
5475	0	0				0	push @check,
5476	0					0	grep({ $_->{router}->{managed} \|\|
5477							$_->{router}->{routing_only} }
5478	0					0	@{ $object->{interfaces} });
5479							}
5480							else {
5481	0 0					0 0	push @check, @{ $object->{interfaces} };
5482							}
5483							}
5484							else {
5485	12	50				14	if ($object->{is_aggregate}) {
5486	0					0	err_msg "Must not use",
5487							" interface:[any:..].[auto]",
5488							" in $context";
5489							}
5490							else {
5491	12					15	push @objects, get_auto_intf $object, $managed;
5492							}
5493							}
5494							}
5495							elsif ($type eq 'Interface') {
5496	0					0	my $router = $object->{router};
5497	0	0 0	0 0			0	if ($managed && !($router->{managed} \|\|
5498							$router->{routing_only}))
5499							{
5500
5501							# Do nothing.
5502							}
5503							elsif ($selector eq 'all') {
5504	0					0	push @check, get_intf($router);
5505							}
5506							else {
5507	0					0	push @objects, get_auto_intf $router;
5508							}
5509							}
5510							elsif ($type eq 'Area') {
5511	6					5	my @routers;
5512
5513							# Prevent duplicates and border routers.
5514							my %seen;
5515
5516							# Don't add routers at border of this area.
5517	6 6					5 10	for my $interface (@{ $object->{border} }) {
5518	4					12	$seen{ $interface->{router} } = 1;
5519							}
5520
5521							# Add routers at border of security zones inside
5522							# current area.
5523	6 16					5 20	for my $router (
5524	12					14	map { $_->{router} }
5525	6					10	map { get_intf($_) }
5526							@{ $object->{zones} }
5527							)
5528							{
5529	16	100				36	if (not $seen{$router}) {
5530	6					4	push @routers, $router;
5531	6					11	$seen{$router} = 1;
5532							}
5533							}
5534	6	100				9	if ($managed) {
5535
5536							# Remove semi managed routers.
5537	4 6	50				5 15	@routers = grep({ $_->{managed} \|\|
5538							$_->{routing_only} }
5539							@routers);
5540							}
5541							else {
5542	2					3	push @routers, map {
5543	2					2	my $r = $_->{unmanaged_routers};
5544	2	50				6	$r ? @$r : ()
5545	2					3	} @{ $object->{zones} };
5546							}
5547	6	100				19	if ($selector eq 'all') {
5548	2 10					2 10	push @check, map { get_intf($_) } @routers;
5549							}
5550							else {
5551	4 6					4 9	push @objects, map { get_auto_intf($_) } @routers;
5552							}
5553							}
5554							elsif ($type eq 'Autointerface') {
5555	0					0	my $obj = $object->{object};
5556	0	0				0	if (is_router $obj) {
5557	0	0 0	0 0			0	if ($managed && !($obj->{managed} \|\|
5558							$obj->{routing_only}))
5559							{
5560
5561							# This router has no managed interfaces.
5562							}
5563							elsif ($selector eq 'all') {
5564	0					0	push @check, get_intf($obj);
5565							}
5566							else {
5567	0					0	push @objects, get_auto_intf $obj;
5568							}
5569							}
5570							else {
5571	0					0	err_msg "Can't use $object->{name} inside",
5572							" interface:[..].[$selector] of $context";
5573							}
5574							}
5575							else {
5576	0					0	err_msg
5577							"Unexpected type '$type' in interface:[..] of $context";
5578							}
5579							}
5580							}
5581
5582							# interface:name.[xxx]
5583							elsif (ref $ext) {
5584	43					45	my ($selector, $managed) = @$ext;
5585	43	50				80	if (my $router = $routers{$name}) {
5586
5587							# Syntactically impossible.
5588	43	50				59	$managed and internal_err();
5589	43	100				54	if ($selector eq 'all') {
5590	12					24	push @check, get_intf($router);
5591							}
5592							else {
5593	31					45	push @objects, get_auto_intf $router;
5594							}
5595							}
5596							else {
5597	0					0	err_msg("Can't resolve $type:$name.[$selector] in $context");
5598							}
5599							}
5600
5601							# interface:name.name
5602							elsif (my $interface = $interfaces{"$name.$ext"}) {
5603	205					237	push @objects, $interface;
5604							}
5605							else {
5606	0					0	err_msg("Can't resolve $type:$name.$ext in $context");
5607							}
5608
5609							# Silently remove unnumbered, bridged and tunnel interfaces
5610							# from automatic groups.
5611	68					112	push @objects,
5612	64					120	grep { $_->{ip} ne 'tunnel' }
5613							$clean_autogrp
5614	266	100				617	? grep { $_->{ip} !~ /^(?:unnumbered\|bridged)$/ } @check
5615							: @check;
5616							}
5617							elsif (ref $name) {
5618	198					209	my $sub_objects = [
5619	198 198					333 374	map { $_->{is_used} = 1; $_; }
5620	183					804	grep { not($_->{disabled}) }
5621	183					168	@{ expand_group1($name, "$type:[..] of $context") }
5622							];
5623							my $get_aggregates = sub {
5624	165			165		178	my ($object, $ip, $mask) = @_;
5625	165					114	my @objects;
5626	165					178	my $type = ref $object;
5627	165	100 100	100			562	if ($type eq 'Area') {
5628	39 20					51 34	push @objects, unique(map({ get_any($_, $ip, $mask) }
5629	20					15	@{ $object->{zones} }));
5630							}
5631							elsif ($type eq 'Network' && $object->{is_aggregate}) {
5632	2					4	push @objects, get_any($object->{zone}, $ip, $mask);
5633							}
5634							else {
5635	143					347	return;
5636							}
5637	22					55	return \@objects;
5638	183					626	};
5639							my $get_networks = sub {
5640	186			186		185	my ($object) = @_;
5641	186					133	my @objects;
5642	186					185	my $type = ref $object;
5643	186	100 100 50	100			647	if ($type eq 'Host' or $type eq 'Interface') {
5644	18					29	push @objects, $object->{network};
5645							}
5646							elsif ($type eq 'Network') {
5647	158	100				206	if (!$object->{is_aggregate}) {
5648	143					156	push @objects, $object;
5649							}
5650
5651							# Take aggregate directly. Don't use next "elsif"
5652							# clause below, where it would be changed to non
5653							# matching aggregate with IP 0/0.
5654							else {
5655	15 15					13 23	push @objects, @{ $object->{networks} };
5656							}
5657							}
5658							elsif (my $aggregates = $get_aggregates->($object, 0, 0)) {
5659	19					31	push(@objects,
5660
5661							# Check type, because $get_aggregates
5662							# eventually returns non aggregate network if
5663							# one matches 0/0.
5664	10 21	100				16 33	map({ $_->{is_aggregate} ? @{ $_->{networks} } : $_ }
5665							@$aggregates));
5666							}
5667							else {
5668	0					0	return;
5669							}
5670	186					356	return \@objects;
5671	183					429	};
5672	183	100 100 50				434	if ($type eq 'host') {
5673	12					13	my $managed = $ext;
5674	12					11	my @hosts;
5675	12					17	for my $object (@$sub_objects) {
5676	12					13	my $type = ref $object;
5677	12	50 50 50				30	if ($type eq 'Host') {
5678	0					0	push @hosts, $object;
5679							}
5680							elsif ($type eq 'Interface') {
5681	0	0				0	if ($object->{is_managed_host}) {
5682	0					0	push @hosts, $object;
5683							}
5684							else {
5685	0					0	err_msg
5686							"Unexpected interface in host:[..] of $context";
5687							}
5688							}
5689							elsif (my $networks = $get_networks->($object)) {
5690	12					15	for my $network (@$networks) {
5691	12 12					9 21	push @hosts, @{ $network->{hosts} };
5692	12	100				27	if (my $managed_hosts = $network->{managed_hosts}) {
5693	8					21	push @hosts, @$managed_hosts;
5694							}
5695							}
5696							}
5697							else {
5698	0					0	err_msg
5699							"Unexpected type '$type' in host:[..] of $context";
5700							}
5701							}
5702	12	100				20	if ($managed) {
5703	4 8					4 12	@hosts = grep { $_->{is_managed_host} } @hosts;
5704							}
5705	12					99	push @objects, @hosts;
5706							}
5707							elsif ($type eq 'network') {
5708	23	50				40	$ext and internal_err;
5709	23					20	my @list;
5710	23					29	for my $object (@$sub_objects) {
5711	31	50				39	if (my $networks = $get_networks->($object)) {
5712
5713							# Silently remove from automatic groups:
5714							# - crosslink network
5715							# - loopback network of managed device
5716							# Change loopback network of unmanaged device
5717							# to loopback interface.
5718							push @list, $clean_autogrp
5719							? map {
5720	47 47	100				61 76	if ($_->{loopback})
5721							{
5722	2					2	my $interfaces = $_->{interfaces};
5723	2					3	my $intf = $interfaces->[0];
5724	2	50				3	if ($intf->{router}->{managed}) {
5725	2					4	();
5726							}
5727							else {
5728	0	0				0	if (@$interfaces > 1) {
5729	0					0	warn_msg(
5730							"Must not use $_->{name},",
5731							" use interfaces instead"
5732							);
5733							}
5734	0					0	$intf;
5735							}
5736							}
5737							else {
5738	45					89	$_;
5739							}
5740							}
5741	31	50				55	grep { not($_->{crosslink}) } @$networks
5742							: @$networks;
5743							}
5744							else {
5745	0					0	my $type = ref $object;
5746	0					0	err_msg("Unexpected type '$type' in network:[..] of",
5747							" $context");
5748							}
5749							}
5750
5751							# Ignore duplicate networks resulting from different
5752							# interfaces connected to the same network.
5753	23					36	push @objects, unique(@list);
5754							}
5755							elsif ($type eq 'any') {
5756	148	100				239	my ($ip, $mask) = $ext ? @$ext : (0, 0);
5757	148					122	my @list;
5758	148					164	for my $object (@$sub_objects) {
5759	155	100 50				218	if (my $aggregates =
5760							$get_aggregates->($object, $ip, $mask))
5761							{
5762	12					26	push @list, @$aggregates;
5763							}
5764							elsif (my $networks = $get_networks->($object)) {
5765	143 143					168 219	push @list, map({ get_any($_->{zone}, $ip, $mask) }
5766							@$networks);
5767							}
5768							else {
5769	0					0	my $type = ref $object;
5770	0					0	err_msg
5771							"Unexpected type '$type' in any:[..]",
5772							" of $context";
5773							}
5774							}
5775
5776							# Ignore duplicate aggregates resulting from different
5777							# interfaces connected to the same aggregate.
5778	148					207	push @objects, unique(@list);
5779							}
5780							else {
5781	0					0	err_msg("Unexpected $type:[..] in $context");
5782							}
5783							}
5784
5785							# An object named simply 'type:name'.
5786							elsif (my $object = $name2object{$type}->{$name}) {
5787
5788	1246	50				1730	$ext
5789							and err_msg("Unexpected '.$ext' after $type:$name in $context");
5790
5791							# Split a group into its members.
5792							# There may be two different versions depending of $clean_autogrp.
5793	1246	100 50	67			1541	if (is_group $object) {
5794
5795							# Two different expanded values, depending on $clean_autogrp.
5796	13	50				24	my $ext = $clean_autogrp ? 'clean' : 'noclean';
5797	13					24	my $attr_name = "expanded_$ext";
5798
5799	13					16	my $elements = $object->{$attr_name};
5800
5801							# Check for recursive definition.
5802	13	50 100				38	if ($object->{recursive}) {
5803	0					0	err_msg("Found recursion in definition of $context");
5804	0					0	$object->{$attr_name} = $elements = [];
5805	0					0	delete $object->{recursive};
5806							}
5807
5808							# Group has not been converted from names to references.
5809							elsif (not $elements) {
5810
5811							# Add marker for detection of recursive group definition.
5812	9					13	$object->{recursive} = 1;
5813
5814							# Mark group as used.
5815	9					10	$object->{is_used} = 1;
5816
5817	9					140	$elements =
5818							expand_group1($object->{elements}, "$type:$name",
5819							$clean_autogrp);
5820	9					15	delete $object->{recursive};
5821
5822							# Private group must not reference private element of other
5823							# context.
5824							# Public group must not reference private element.
5825	9		50			38	my $private1 = $object->{private} \|\| 'public';
5826	9					11	for my $element (@$elements) {
5827	24	50				49	if (my $private2 = $element->{private}) {
5828	0	0				0	$private1 eq $private2
5829							or err_msg(
5830							"$private1 $object->{name} must not",
5831							" reference $private2 $element->{name}"
5832							);
5833							}
5834							}
5835
5836							# Detect and remove duplicate values in group.
5837	9					9	my %unique;
5838							my @duplicate;
5839	9					15	for my $obj (@$elements) {
5840	24	50				64	if ($unique{$obj}++) {
5841	0					0	push @duplicate, $obj;
5842	0					0	$obj = undef;
5843							}
5844							}
5845	9	50				19	if (@duplicate) {
5846	0 0					0 0	$elements = [ grep { defined $_ } @$elements ];
5847	0					0	my $msg = "Duplicate elements in $type:$name:\n "
5848	0					0	. join("\n ", map { $_->{name} } @duplicate);
5849	0					0	warn_msg($msg);
5850							}
5851
5852							# Cache result for further references to the same group
5853							# in same $clean_autogrp context.
5854	9					19	$object->{$attr_name} = $elements;
5855							}
5856	13					34	push @objects, @$elements;
5857							}
5858
5859							# Substitute aggregate by aggregate set of zone cluster.
5860							elsif ($object->{is_aggregate} && $object->{zone}->{zone_cluster}) {
5861	0 0					0 0	my ($ip, $mask) = @{$object}{qw(ip mask)};
5862	0					0	push(@objects,
5863							get_cluster_aggregates($object->{zone}, $ip, $mask));
5864							}
5865
5866							else {
5867	1233					2446	push @objects, $object;
5868							}
5869
5870							}
5871							else {
5872	0					0	err_msg("Can't resolve $type:$name in $context");
5873							}
5874							}
5875	1763					2561	return \@objects;
5876							}
5877
5878							# Remove and warn about duplicate values in group.
5879							sub remove_duplicates {
5880	1530			1530	0	1381	my ($aref, $context) = @_;
5881	1530					1133	my %seen;
5882							my @duplicate;
5883	1530					1552	for my $obj (@$aref) {
5884	2022	100				5553	if ($seen{$obj}++) {
5885	1					2	push @duplicate, $obj;
5886	1					1	$obj = undef;
5887							}
5888							}
5889	1530	100				2373	if (@duplicate) {
5890	1					4	my $msg = "Duplicate elements in $context:\n "
5891	1					3	. join("\n ", map { $_->{name} } @duplicate);
5892	1					2	warn_msg($msg);
5893	1 3					2 5	$aref = [ grep { defined $_ } @$aref ];
5894							}
5895	1530					2175	return $aref;
5896							}
5897
5898							sub expand_group {
5899	1525			1525	0	1443	my ($obref, $context) = @_;
5900	1525					1817	my $aref = expand_group1 $obref, $context, 'clean_autogrp';
5901	1525					1913	$aref = remove_duplicates($aref, $context);
5902
5903							# Ignore disabled objects.
5904	1525					1189	my $changed;
5905	1525					1494	for my $object (@$aref) {
5906	2011	100				3786	if ($object->{disabled}) {
5907	2					2	$object = undef;
5908	2					2	$changed = 1;
5909							}
5910							}
5911	1525 2	100				2105 4	$aref = [ grep { defined $_ } @$aref ] if $changed;
5912	1525					2263	return $aref;
5913							}
5914
5915							my %subnet_warning_seen;
5916
5917							sub expand_group_in_rule {
5918	602			602	0	947	my ($obref, $context, $convert_hosts) = @_;
5919	602					734	my $aref = expand_group($obref, $context);
5920
5921							# Ignore unusable objects.
5922	602					477	my $changed;
5923	602					601	for my $object (@$aref) {
5924	766					551	my $ignore;
5925	766	100 100 50				910	if (is_network $object) {
5926	565	50 50 100				1870	if ($object->{ip} eq 'unnumbered') {
5927	0					0	$ignore = "unnumbered $object->{name}";
5928							}
5929							elsif ($object->{crosslink}) {
5930	0					0	$ignore = "crosslink $object->{name}";
5931							}
5932							elsif ($object->{is_aggregate}) {
5933	94	50 100				218	if ($object->{is_tunnel}) {
5934	0					0	$ignore = "$object->{name} with tunnel";
5935							}
5936							elsif ($object->{has_id_hosts}) {
5937	1					2	$ignore = "$object->{name} with software clients"
5938							}
5939							}
5940							}
5941							elsif (is_interface $object) {
5942	83	50				227	if ($object->{ip} =~ /^(short\|unnumbered)$/) {
5943	0					0	$ignore = "$object->{ip} $object->{name}";
5944							}
5945							}
5946							elsif (is_area $object) {
5947	0					0	$ignore = $object->{name};
5948							}
5949	766	100				1520	if ($ignore) {
5950	1					6	$object = undef;
5951	1					1	$changed = 1;
5952	1					4	warn_msg("Ignoring $ignore in $context");
5953							}
5954							}
5955	602 1	100				837 2	$aref = [ grep { defined $_ } @$aref ] if $changed;
5956
5957	602	100				749	if ($convert_hosts) {
5958	596					483	my @subnets;
5959							my %subnet2host;
5960	0					0	my @other;
5961	596					602	for my $obj (@$aref) {
5962
5963							# debug("group:$obj->{name}");
5964	752	100				851	if (is_host $obj) {
5965	97 97					87 137	for my $subnet (@{ $obj->{subnets} }) {
5966
5967							# Handle special case, where network and subnet
5968							# have identical address.
5969							# E.g. range = 10.1.1.0-10.1.1.255.
5970							# Convert subnet to network, because
5971							# - different objects with identical IP
5972							# can't be checked and optimized properly,
5973							# - find_chains would fail, when building binary tree.
5974	103	100 50				283	if ($subnet->{mask} == $subnet->{network}->{mask}) {
5975	1					2	my $network = $subnet->{network};
5976	1	50	33			5	if (not $network->{has_id_hosts} and
5977							not $subnet_warning_seen{$subnet}++)
5978							{
5979	1					9	warn_msg("Use $network->{name} instead of",
5980							" $subnet->{name}\n",
5981							" because both have identical address");
5982							}
5983	1					4	push @other, $network;
5984							}
5985							elsif (my $host = $subnet2host{$subnet}) {
5986	0					0	warn_msg("$obj->{name} and $host->{name}",
5987							" overlap in $context");
5988							}
5989							else {
5990	102					149	$subnet2host{$subnet} = $obj;
5991	102					231	push @subnets, $subnet;
5992							}
5993							}
5994							}
5995							else {
5996	655					989	push @other, $obj;
5997							}
5998							}
5999	596					801	push @other, ($convert_hosts eq 'no_combine')
6000							? @subnets
6001	596	50				858	: @{ combine_subnets \@subnets };
6002	596					1207	return \@other;
6003							}
6004							else {
6005	6					12	return $aref;
6006							}
6007
6008							}
6009
6010							sub check_unused_groups {
6011							my $check = sub {
6012	452			452		432	my ($hash, $print_type) = @_;
6013	452	50				1027	my $print = $print_type eq 'warn' ? \&warn_msg : \&err_msg;
6014	452					1159	for my $name (sort keys %$hash) {
6015	2					3	my $value = $hash->{$name};
6016	2	50				8	next if $value->{is_used};
6017	0					0	$print->("unused $value->{name}");
6018							}
6019	226			226	0	750	};
6020	226	50				478	if (my $conf = $config{check_unused_groups}) {
6021	226					307	for my $hash (\%groups, \%protocolgroups) {
6022	452					890	$check->($hash, $conf);
6023							}
6024							}
6025	226	50				453	if (my $conf = $config{check_unused_protocols}) {
6026	0					0	for my $hash (\%protocols) {
6027	0					0	$check->($hash, $conf);
6028							}
6029							}
6030
6031							# Not used any longer; free memory.
6032	226					275	%groups = ();
6033	226					1166	return;
6034							}
6035
6036							# Result:
6037							# Reference to array with elements
6038							# - non TCP/UDP protocol
6039							# - dst_range of (splitted) TCP/UDP protocol
6040							# - [ src_range, dst_range, orig_prt ]
6041							# of (splitted) protocol having src_range or main_prt.
6042							sub expand_protocols {
6043	333			333	0	331	my ($aref, $context) = @_;
6044	333					260	my @protocols;
6045	333					379	for my $pair (@$aref) {
6046
6047							# Handle anonymous protocol.
6048	354	100				650	if (ref($pair) eq 'HASH') {
6049	322					344	push @protocols, $pair;
6050	322					462	next;
6051							}
6052
6053	32					41	my ($type, $name) = @$pair;
6054	32	100 50				64	if ($type eq 'protocol') {
6055	31	50				61	if (my $prt = $protocols{$name}) {
6056	31					31	push @protocols, $prt;
6057
6058							# Currently needed by external program 'cut-netspoc'.
6059	31					68	$prt->{is_used} = 1;
6060							}
6061							else {
6062	0					0	err_msg("Can't resolve reference to $type:$name in $context");
6063	0					0	next;
6064							}
6065							}
6066							elsif ($type eq 'protocolgroup') {
6067	1	50				3	if (my $prtgroup = $protocolgroups{$name}) {
6068	1					1	my $elements = $prtgroup->{elements};
6069	1	50 50				4	if ($elements eq 'recursive') {
6070	0					0	err_msg("Found recursion in definition of $context");
6071	0					0	$prtgroup->{elements} = $elements = [];
6072							}
6073
6074							# Check if it has already been converted
6075							# from names to references.
6076							elsif (not $prtgroup->{is_used}) {
6077
6078							# Detect recursive definitions.
6079	1					2	$prtgroup->{elements} = 'recursive';
6080	1					1	$prtgroup->{is_used} = 1;
6081	1					7	$elements = expand_protocols($elements, "$type:$name");
6082
6083							# Cache result for further references to the same group.
6084	1					2	$prtgroup->{elements} = $elements;
6085							}
6086
6087							# Split only once.
6088	1					2	push @protocols, @$elements;
6089							}
6090							else {
6091	0					0	err_msg("Can't resolve reference to $type:$name in $context");
6092	0					0	next;
6093							}
6094							}
6095							else {
6096	0					0	err_msg("Unknown type of $type:$name in $context");
6097							}
6098							}
6099	333					690	return \@protocols;
6100							}
6101
6102							# Expand splitted protocols.
6103							sub split_protocols {
6104	319			319	0	300	my ($protocols, $context) = @_;
6105	319					252	my @splitted_protocols;
6106	319					359	for my $prt (@$protocols) {
6107	340					348	my $proto = $prt->{proto};
6108	340	100	100			820	if (not($proto eq 'tcp' or $proto eq 'udp')) {
6109	76					81	push @splitted_protocols, $prt;
6110	76					120	next;
6111							}
6112
6113							# Collect splitted src_range / dst_range pairs.
6114	264					251	my $dst_range = $prt->{dst_range};
6115	264					240	my $src_range = $prt->{src_range};
6116
6117							# Remember original protocol as third value
6118							# - if src_range is given or
6119							# - if original protocol has flags or
6120							# - if $dst_range is shared between different protocols.
6121							# Cache list of triples at original protocol for re-use.
6122	264	100	100			1679	if ($src_range or $prt->{flags} or $dst_range->{name} ne $prt->{name}) {
6123	28					34	my $aref_list = $prt->{src_dst_range_list};
6124	28	100				45	if (not $aref_list) {
6125	26					41	for my $src_split (expand_splitted_protocol $src_range) {
6126	26					36	for my $dst_split (expand_splitted_protocol $dst_range) {
6127	26					78	push @$aref_list, [$src_split, $dst_split, $prt];
6128							}
6129							}
6130	26					38	$prt->{src_dst_range_list} = $aref_list;
6131							}
6132	28					50	push @splitted_protocols, @$aref_list;
6133							}
6134							else {
6135	236					316	for my $dst_split (expand_splitted_protocol $dst_range) {
6136	237					596	push @splitted_protocols, $dst_split;
6137							}
6138							}
6139							}
6140	319					458	return \@splitted_protocols;
6141							}
6142
6143							sub path_auto_interfaces;
6144
6145							# Hash with attributes deny, supernet, permit for storing
6146							# expanded rules of different type.
6147							our %expanded_rules;
6148
6149							# Hash for ordering all rules.
6150							# Put attributes with small value set first, to get a more
6151							# memory efficient tree with few branches at root.
6152							# $rule_tree{$stateless}->{$deny}->{$src_range}->{$src}->{$dst}->{$prt}
6153							# = $rule;
6154							my %rule_tree;
6155
6156							# Collect deleted rules for further inspection.
6157							my @deleted_rules;
6158
6159							# Add rules to %rule_tree for efficient look up.
6160							sub add_rules {
6161	1020			1020	0	889	my ($rules_ref, $rule_tree) = @_;
6162	1020		100			1888	$rule_tree \|\|= \%rule_tree;
6163
6164	1020					1095	for my $rule (@$rules_ref) {
6165	630					1055	my ($stateless, $deny, $src, $dst, $src_range, $prt) =
6166	630					889	@{$rule}{ qw(stateless deny src dst src_range prt) };
6167
6168							# A rule with an interface as destination may be marked as deleted
6169							# during global optimization. But in some cases, code for this rule
6170							# must be generated anyway. This happens, if
6171							# - it is an interface of a managed router and
6172							# - code is generated for exactly this router.
6173							# Mark such rules for easier handling.
6174	630	100	50			756	if (is_interface($dst) && ($dst->{router}->{managed} \|\|
6175							$dst->{router}->{routing_only}))
6176							{
6177	125					144	$rule->{managed_intf} = 1;
6178							}
6179	630		100			1450	$stateless \|\|= '';
6180	630		100			1362	$deny \|\|= '';
6181	630		67			1287	$src_range \|\|= $prt_ip;
6182	630					2030	my $old_rule =
6183							$rule_tree->{$stateless}->{$deny}->{$src_range}->{$src}->{$dst}
6184							->{$prt};
6185	630	100				854	if ($old_rule) {
6186
6187							# Found identical rule.
6188	7					6	$rule->{deleted} = $old_rule;
6189	7					6	push @deleted_rules, $rule;
6190	7					12	next;
6191							}
6192
6193							# debug("Add:", print_rule $rule);
6194	623					2148	$rule_tree->{$stateless}->{$deny}->{$src_range}->{$src}->{$dst}
6195							->{$prt} = $rule;
6196							}
6197	1020					1046	return;
6198							}
6199
6200							my %obj2zone;
6201
6202							sub get_zone {
6203	780			780	0	673	my ($obj) = @_;
6204	780					767	my $type = ref $obj;
6205	780					564	my $result;
6206
6207							# A router or network with [auto] interface.
6208	780	100				1132	if ($type eq 'Autointerface') {
6209	21					20	$obj = $obj->{object};
6210	21					22	$type = ref $obj;
6211							}
6212
6213	780	100 100 100 50 0				1138	if ($type eq 'Network') {
6214	589					580	$result = $obj->{zone};
6215							}
6216							elsif ($type eq 'Subnet') {
6217	93					121	$result = $obj->{network}->{zone};
6218							}
6219							elsif ($type eq 'Interface') {
6220	82	100				142	if ($obj->{router}->{managed}) {
6221	57					59	$result = $obj->{router};
6222							}
6223							else {
6224	25					29	$result = $obj->{network}->{zone};
6225							}
6226							}
6227
6228							# Only used when called from expand_rules.
6229							elsif ($type eq 'Router') {
6230	16	100				22	if ($obj->{managed}) {
6231	7					7	$result = $obj;
6232							}
6233							else {
6234	9					15	$result = $obj->{interfaces}->[0]->{network}->{zone};
6235							}
6236							}
6237							elsif ($type eq 'Host') {
6238	0					0	$result = $obj->{network}->{zone};
6239							}
6240							else {
6241	0					0	internal_err("unexpected $obj->{name}");
6242							}
6243	780					2066	return($obj2zone{$obj} = $result);
6244							}
6245
6246							sub path_walk;
6247
6248							sub expand_special {
6249	958			958	0	1318	my ($src, $dst, $flags, $context) = @_;
6250	958					690	my @result;
6251	958	100				1070	if (is_autointerface $src) {
6252	21					28	for my $interface (path_auto_interfaces $src, $dst) {
6253	34	50 50				64	if ($interface->{ip} eq 'short') {
6254	0					0	err_msg "'$interface->{ip}' $interface->{name}",
6255							" (from .[auto])\n", " must not be used in rule of $context";
6256							}
6257							elsif ($interface->{ip} eq 'unnumbered') {
6258
6259							# Ignore unnumbered interfaces.
6260							}
6261							else {
6262	34					45	push @result, $interface;
6263							}
6264							}
6265							}
6266							else {
6267	937					986	@result = ($src);
6268							}
6269	958	100				1620	if ($flags->{net}) {
6270	4					5	my @networks;
6271							my @other;
6272	4					6	for my $obj (@result) {
6273	4					4	my $type = ref $obj;
6274	4					3	my $network;
6275	4	50 100 50	67			17	if ($type eq 'Network') {
6276	0					0	$network = $obj;
6277							}
6278							elsif ($type eq 'Subnet' or $type eq 'Host') {
6279	3	50				5	if ($obj->{id}) {
6280	0					0	push @other, $obj;
6281	0					0	next;
6282							}
6283							else {
6284	3					4	$network = $obj->{network};
6285							}
6286							}
6287							elsif ($type eq 'Interface') {
6288	1	50	33			3	if ($obj->{router}->{managed} \|\| $obj->{loopback}) {
6289	1					2	push @other, $obj;
6290	1					2	next;
6291							}
6292							else {
6293	0					0	$network = $obj->{network};
6294							}
6295							}
6296							else {
6297	0					0	internal_err("unexpected $obj->{name}");
6298							}
6299	3	50				10	push @networks, $network if $network->{ip} ne 'unnumbered';
6300							}
6301	4					7	@result = (@other, unique(@networks));
6302							# debug "special: ", join(', ', map { $_->{name} } @result);
6303							}
6304	958	50				1306	if ($flags->{any}) {
6305	0					0	my %zones;
6306	0					0	for my $obj (@result) {
6307	0					0	my $type = ref $obj;
6308	0					0	my $zone;
6309	0	0 0	0			0	if ($type eq 'Network') {
6310	0					0	$zone = $obj->{zone};
6311							}
6312							elsif ($type eq 'Subnet' or $type eq 'Interface' or $type eq 'Host')
6313							{
6314	0					0	$zone = $obj->{network}->{zone};
6315							}
6316							else {
6317	0					0	internal_err("unexpected $obj->{name}");
6318							}
6319	0					0	$zones{$zone} = $zone;
6320							}
6321	0 0					0 0	@result = map { get_any($_, 0, 0) } values %zones;
6322							}
6323	958					1853	return @result;
6324							}
6325
6326							# Add managed hosts of networks and aggregates.
6327							sub add_managed_hosts {
6328	298			298	0	310	my ($aref, $context) = @_;
6329	298					239	my @extra;
6330	298					336	for my $object (@$aref) {
6331	368	100				878	my $managed_hosts = $object->{managed_hosts} or next;
6332	5					8	push @extra, @$managed_hosts;
6333							}
6334	298	100				524	if (@extra) {
6335	5					5	push @$aref, @extra;
6336	5					7	$aref = remove_duplicates($aref, $context);
6337							}
6338	298					343	return $aref;
6339							}
6340
6341							# This handles a rule between objects inside a single security zone or
6342							# between interfaces of a single managed router.
6343							# Show warning or error message if rule is between
6344							# - different interfaces or
6345							# - different networks or
6346							# - subnets/hosts of different networks.
6347							# Rules between identical objects are silently ignored.
6348							# But a message is shown if a service only has rules between identical objects.
6349							sub collect_unenforceable {
6350	23			23	0	23	my ($src, $dst, $zone, $service) = @_;
6351
6352	23	100				43	if ($zone->{has_unenforceable}) {
6353	2					3	$zone->{seen_unenforceable} = 1;
6354	2					7	$service->{silent_unenforceable} = 1;
6355	2					2	return;
6356							}
6357
6358	21					21	my $context = $service->{name};
6359	21					24	$service->{silent_unenforceable} = 1;
6360
6361							# A rule between identical objects is a common case
6362							# which results from rules with "src=user;dst=user;".
6363	21	100				47	return if $src eq $dst;
6364
6365	8	50 100 50 50 100 50	67 100 33 33			11	if (is_router $zone) {
6366
6367							# Auto interface is assumed to be identical
6368							# to each other interface of a single router.
6369	0	0	0			0	return if is_autointerface($src) or is_autointerface($dst);
6370							}
6371							elsif (is_subnet $src and is_subnet($dst)) {
6372
6373							# For rules with different subnets of a single network we don't
6374							# know if the subnets have been split from a single range.
6375							# E.g. range 1-4 becomes four subnets 1,2-3,4
6376							# For most splits the resulting subnets would be adjacent.
6377							# Hence we check for adjacency.
6378	2	50				6	if ($src->{network} eq $dst->{network}) {
6379	2	50				4	my ($a, $b) = $src->{ip} > $dst->{ip} ? ($dst, $src) : ($src, $dst);
6380	2	50				3	if ($a->{ip} + complement_32bit($a->{mask}) + 1 == $b->{ip}) {
6381	0					0	return;
6382							}
6383							}
6384							}
6385							elsif ($src->{is_aggregate} && $dst->{is_aggregate}) {
6386
6387							# Both are aggregates,
6388							# - belonging to same zone cluster and
6389							# - having identical ip and mask
6390	0	0	0			0	return if (zone_eq($src->{zone}, $dst->{zone})
6391							&& $src->{ip} == $dst->{ip}
6392							&& $src->{mask} == $dst->{mask});
6393							}
6394							elsif ($src->{is_aggregate} && $src->{mask} == 0) {
6395
6396							# This is a common case, which results from rules like
6397							# group:some_networks -> any:[group:some_networks]
6398	0	0				0	return if zone_eq($src->{zone}, get_zone($dst))
6399							}
6400							elsif ($dst->{is_aggregate} && $dst->{mask} == 0 ) {
6401	3	50				5	return if zone_eq($dst->{zone}, get_zone($src))
6402							}
6403							elsif ($dst->{managed_hosts}) {
6404
6405							# Network or aggregate was only used for its managed_hosts
6406							# to be added automatically in expand_group.
6407	0					0	return;
6408							}
6409	5		50			28	$service->{seen_unenforceable}->{$src}->{$dst} \|\|= [ $src, $dst ];
6410	5					8	return;
6411							}
6412
6413							sub show_unenforceable {
6414	261			261	0	265	my ($service) = @_;
6415	261					284	my $context = $service->{name};
6416
6417	261	100	100 67			525	if ($service->{has_unenforceable} &&
6418							(! $service->{seen_unenforceable} \|\| ! $service->{seen_enforceable}))
6419							{
6420	1					4	warn_msg("Useless attribute 'has_unenforceable' at $context");
6421							}
6422	261	50				479	return if ! $config{check_unenforceable};
6423	261	50				399	return if $service->{disabled};
6424
6425	261	50				493	my $print = $config{check_unenforceable} eq 'warn' ? \&warn_msg : \&err_msg;
6426
6427							# Warning about fully unenforceable service can't be disabled with
6428							# attribute has_unenforceable.
6429	261	100				559	if (! delete $service->{seen_enforceable}) {
6430
6431							# Don't warn on empty service without any expanded rules.
6432	5	100	67			24	if ($service->{seen_unenforceable} \|\| $service->{silent_unenforceable})
6433							{
6434	3					10	$print->("$context is fully unenforceable");
6435							}
6436	5					8	return;
6437							}
6438	256	100				407	return if $service->{has_unenforceable};
6439
6440	255	100				450	if (my $hash = delete $service->{seen_unenforceable}) {
6441	1					2	my $msg = "$context has unenforceable rules:";
6442	1					2	for my $hash (values %$hash) {
6443	1					2	for my $aref (values %$hash) {
6444	1					1	my ($src, $dst) = @$aref;
6445	1					5	$msg .= "\n src=$src->{name}; dst=$dst->{name}";
6446							}
6447							}
6448	1					2	$print->($msg);
6449							}
6450	255					250	delete $service->{silent_unenforceable};
6451	255					322	return;
6452							}
6453
6454							sub warn_useless_unenforceable {
6455	315			315	0	364	for my $zone (@zones) {
6456	825	100				1408	$zone->{has_unenforceable} or next;
6457	2	100				5	$zone->{seen_unenforceable} and next;
6458	1					2	my $agg00 = $zone->{ipmask2aggregate}->{'0/0'};
6459	1	50				2	my $name = $agg00 ? $agg00->{name} : $zone->{name};
6460	1					3	warn_msg("Useless attribute 'has_unenforceable' at $name");
6461							}
6462	315					297	return;
6463							}
6464
6465							sub show_deleted_rules1 {
6466	315	100		315	0	522	return if not @deleted_rules;
6467	1					2	my %sname2oname2deleted;
6468							RULE:
6469	1					1	for my $rule (@deleted_rules) {
6470	1					4	my $other = $rule->{deleted};
6471
6472	1		33			4	my $prt1 = $rule->{orig_prt} \|\| $rule->{prt};
6473	1		33			4	my $prt2 = $other->{orig_prt} \|\| $other->{prt};
6474	1	50	33			3	next if $prt1->{flags}->{overlaps} && $prt2->{flags}->{overlaps};
6475
6476	1					2	my $service = $rule->{rule}->{service};
6477	1					1	my $oservice = $other->{rule}->{service};
6478	1	50				2	if (my $overlaps = $service->{overlaps}) {
6479	1					2	for my $overlap (@$overlaps) {
6480	1	50				2	if ($oservice eq $overlap) {
6481	1					3	$service->{overlaps_used}->{$overlap} = $overlap;
6482	1					3	next RULE;
6483							}
6484							}
6485							}
6486	0	0				0	if (my $overlaps = $oservice->{overlaps}) {
6487	0					0	for my $overlap (@$overlaps) {
6488	0	0				0	if ($service eq $overlap) {
6489	0					0	$oservice->{overlaps_used}->{$overlap} = $overlap;
6490	0					0	next RULE;
6491							}
6492							}
6493							}
6494	0					0	my $sname = $service->{name};
6495	0					0	my $oname = $oservice->{name};
6496	0					0	my $pfile = $service->{file};
6497	0					0	my $ofile = $oservice->{file};
6498	0					0	$pfile =~ s/.*?([^\/]+)$/$1/;
6499	0					0	$ofile =~ s/.*?([^\/]+)$/$1/;
6500	0 0					0 0	push(@{ $sname2oname2deleted{$sname}->{$oname} }, $rule);
6501							}
6502	1	50				3	if (my $action = $config{check_duplicate_rules}) {
6503	1	50				2	my $print = $action eq 'warn' ? \&warn_msg : \&err_msg;
6504	1					3	for my $sname (sort keys %sname2oname2deleted) {
6505	0					0	my $hash = $sname2oname2deleted{$sname};
6506	0					0	for my $oname (sort keys %$hash) {
6507	0					0	my $aref = $hash->{$oname};
6508	0					0	my $msg = "Duplicate rules in $sname and $oname:\n ";
6509	0 0					0 0	$msg .= join("\n ", map { print_rule $_ } @$aref);
6510	0					0	$print->($msg);
6511							}
6512							}
6513							}
6514
6515							# Variable will be reused during sub optimize.
6516	1					2	@deleted_rules = ();
6517	1					1	return;
6518							}
6519
6520							sub collect_redundant_rules {
6521	32			32	0	32	my ($rule, $other) = @_;
6522
6523							# Ignore automatically generated rules from crypto or from reverse rules.
6524	32	100				60	return if !$rule->{rule};
6525	24	50				37	return if !$other->{rule};
6526
6527	24		67			64	my $prt1 = $rule->{orig_prt} \|\| $rule->{prt};
6528	24		67			60	my $prt2 = $other->{orig_prt} \|\| $other->{prt};
6529	24	50	33			61	return if $prt1->{flags}->{overlaps} && $prt2->{flags}->{overlaps};
6530
6531							# Rule is still needed at device of $rule->{dst}.
6532	24	100	67			48	if ($rule->{managed_intf} and not $rule->{deleted}->{managed_intf}) {
6533	1					1	return;
6534							}
6535
6536							# Automatically generated reverse rule for stateless router
6537							# is still needed, even for stateful routers for static routes.
6538	23					25	my $src = $rule->{src};
6539	23	50				29	if (is_interface($src)) {
6540	0					0	my $router = $src->{router};
6541	0	0	0			0	if ($router->{managed} \|\| $router->{routing_only}) {
6542	0					0	return;
6543							}
6544							}
6545
6546	23					30	my $service = $rule->{rule}->{service};
6547	23					22	my $oservice = $other->{rule}->{service};
6548	23	50				41	if (!$oservice) {
6549	0					0	debug "d:", print_rule $rule;
6550	0					0	debug "o:", print_rule $other;
6551							}
6552	23	100				43	if (my $overlaps = $service->{overlaps}) {
6553	4					4	for my $overlap (@$overlaps) {
6554	4	100				10	if ($oservice eq $overlap) {
6555	3					7	$service->{overlaps_used}->{$overlap} = $overlap;
6556	3					4	return;
6557							}
6558							}
6559							}
6560	20					27	push @deleted_rules, [ $rule, $other ];
6561	20					25	return;
6562							}
6563
6564							sub show_deleted_rules2 {
6565	226	100		226	0	361	return if not @deleted_rules;
6566	13					14	my %sname2oname2deleted;
6567	13					15	for my $pair (@deleted_rules) {
6568	20					24	my ($rule, $other) = @$pair;
6569
6570	20					22	my $service = $rule->{rule}->{service};
6571	20					22	my $oservice = $other->{rule}->{service};
6572	20					23	my $sname = $service->{name};
6573	20					18	my $oname = $oservice->{name};
6574	20					20	my $pfile = $service->{file};
6575	20					19	my $ofile = $oservice->{file};
6576	20					199	$pfile =~ s/.*?([^\/]+)$/$1/;
6577	20					166	$ofile =~ s/.*?([^\/]+)$/$1/;
6578	20 20					22 80	push(@{ $sname2oname2deleted{$sname}->{$oname} }, [ $rule, $other ]);
6579							}
6580	13	100				32	if (my $action = $config{check_redundant_rules}) {
6581	11	50				21	my $print = $action eq 'warn' ? \&warn_msg : \&err_msg;
6582	11					28	for my $sname (sort keys %sname2oname2deleted) {
6583	15					19	my $hash = $sname2oname2deleted{$sname};
6584	15					36	for my $oname (sort keys %$hash) {
6585	17					22	my $aref = $hash->{$oname};
6586	17					43	my $msg = "Redundant rules in $sname compared to $oname:\n ";
6587	18					19	$msg .= join(
6588							"\n ",
6589							map {
6590	17					25	my ($r, $o) = @$_;
6591	18					28	print_rule($r) . "\n< " . print_rule($o);
6592							} @$aref
6593							);
6594	17					26	$print->($msg);
6595							}
6596							}
6597							}
6598
6599							# Free memory.
6600	13					23	@deleted_rules = ();
6601
6602	13					31	return;
6603							}
6604
6605							sub warn_unused_overlaps {
6606	226			226	0	465	for my $key (sort keys %services) {
6607	239					309	my $service = $services{$key};
6608	239	50				386	next if $service->{disabled};
6609	239	100				538	if (my $overlaps = $service->{overlaps}) {
6610	4					5	my $used = delete $service->{overlaps_used};
6611	4					7	for my $overlap (@$overlaps) {
6612	4	50				7	next if $overlap->{disabled};
6613	4	50				19	$used->{$overlap}
6614							or warn_msg("Useless 'overlaps = $overlap->{name}'",
6615							" in $service->{name}");
6616							}
6617							}
6618							}
6619	226					232	return;
6620							}
6621
6622							# All log tags defined at some routers.
6623							my %known_log;
6624
6625							sub collect_log {
6626	315			315	0	363	for my $router (@managed_routers) {
6627	451	100				928	my $log = $router->{log} or next;
6628	19					30	for my $tag (keys %$log) {
6629	34					61	$known_log{$tag} = 1;
6630							}
6631							}
6632	315					285	return;
6633							}
6634
6635							sub check_log {
6636	18			18	0	16	my ($log, $context) = @_;
6637	18					16	for my $tag (@$log) {
6638	20	100				44	$known_log{$tag} and next;
6639	1					4	warn_msg("Referencing unknown '$tag' in log of $context");
6640	1					2	aref_delete($log, $tag);
6641							}
6642	18					20	return;
6643							}
6644
6645							# Normalize lists of log tags at different rules in such a way,
6646							# that equal sets of tags are represented by 'eq' array references.
6647							my %key2log;
6648							sub normalize_log {
6649	17			17	0	14	my ($log) = @_;
6650	17					29	my @tags = sort @$log;
6651	17					25	my $key = join(',', @tags);
6652	17		100			62	return $key2log{$key} \|\|= \@tags;
6653							}
6654
6655							# Parameters:
6656							# - The service.
6657							# - Reference to array for storing resulting expanded rules.
6658							# - Flag which will be passed on to expand_group.
6659							sub expand_rules {
6660	261			261	0	276	my ($service, $result, $convert_hosts) = @_;
6661	261					269	my $rules_ref = $service->{rules};
6662	261					255	my $user = $service->{user};
6663	261					232	my $context = $service->{name};
6664	261					237	my $disabled = $service->{disabled};
6665	261					235	my $private = $service->{private};
6666	261					591	my $foreach = $service->{foreach};
6667
6668	261					291	for my $unexpanded (@$rules_ref) {
6669	298					381	my $deny = $unexpanded->{action} eq 'deny';
6670	298					271	my $log = $unexpanded->{log};
6671	298	100				444	if ($log) {
6672	18					21	check_log($log, $context);
6673	18	100				34	if (@$log) {
6674	17					21	$log = normalize_log($log);
6675							}
6676							else {
6677	1					1	$log = undef;
6678							}
6679							}
6680	298					658	my $prt_list = split_protocols(expand_protocols($unexpanded->{prt},
6681							"rule in $context"));
6682	298	50				556	for my $element ($foreach ? @$user : $user) {
6683	298					318	$user_object->{elements} = $element;
6684	298					704	my $src = expand_group_in_rule($unexpanded->{src},
6685							"src of rule in $context",
6686							$convert_hosts);
6687	298					461	my $dst_context = "dst of rule in $context";
6688	298					778	my $dst = expand_group_in_rule($unexpanded->{dst},
6689							$dst_context,
6690							$convert_hosts);
6691	298					463	$dst = add_managed_hosts($dst, $dst_context);
6692	298					323	for my $prt (@$prt_list) {
6693
6694							# Prevent modification of original array.
6695	313					275	my $prt = $prt;
6696
6697							# If $prt is duplicate of an identical protocol,
6698							# use the main protocol, but remember the original
6699							# one for debugging / comments.
6700	313					595	my $orig_prt;
6701							my $src_range;
6702	313	100 100				802	if (ref $prt eq 'ARRAY') {
6703	23					39	($src_range, $prt, $orig_prt) = @$prt;
6704							}
6705							elsif (my $main_prt = $prt->{main}) {
6706	34					27	$orig_prt = $prt;
6707	34					35	$prt = $main_prt;
6708							}
6709
6710	313	100				468	my $flags = $orig_prt ? $orig_prt->{flags} : $prt->{flags};
6711	313					313	my $stateless = $flags->{stateless};
6712	313	100				487	my ($src, $dst) =
6713							$flags->{reversed} ? ($dst, $src) : ($src, $dst);
6714
6715	313					347	for my $src (@$src) {
6716	409		67			1062	my $src_zone = $obj2zone{$src} \|\| get_zone $src;
6717	409					406	my $src_zone_cluster = $src_zone->{zone_cluster};
6718	409					452	for my $dst (@$dst) {
6719	502		67			1102	my $dst_zone = $obj2zone{$dst} \|\| get_zone $dst;
6720	502					477	my $dst_zone_cluster = $dst_zone->{zone_cluster};
6721	502	100	60			1600	if ( $src_zone eq $dst_zone
6722							\|\| $src_zone_cluster
6723							&& $dst_zone_cluster
6724							&& $src_zone_cluster eq $dst_zone_cluster)
6725							{
6726	23					36	collect_unenforceable(
6727							$src, $dst, $src_zone, $service);
6728	23					65	next;
6729							}
6730
6731							# At least one rule is enforceable.
6732							# This is used to decide, if a service is fully
6733							# unenforceable.
6734	479					531	$service->{seen_enforceable} = 1;
6735
6736	479	50				1044	my @src =
6737							expand_special($src, $dst, $flags->{src}, $context)
6738							or next; # Prevent multiple error messages.
6739	479					2325	my @dst =
6740							expand_special($dst, $src, $flags->{dst}, $context);
6741	479					634	for my $src (@src) {
6742	479					456	for my $dst (@dst) {
6743	492	50				579	if ($private) {
6744	0					0	my $src_p = $src->{private};
6745	0					0	my $dst_p = $dst->{private};
6746	0	0	0			0	$src_p and $src_p eq $private
6747							or $dst_p and $dst_p eq $private
6748							or err_msg
6749							"Rule of $private.private $context",
6750							" must reference at least one object",
6751							" out of $private.private";
6752							}
6753							else {
6754	492	50				751	$src->{private}
6755							and err_msg
6756							"Rule of public $context must not",
6757							" reference $src->{name} of",
6758							" $src->{private}.private";
6759	492	50				750	$dst->{private}
6760							and err_msg
6761							"Rule of public $context must not",
6762							" reference $dst->{name} of",
6763							" $dst->{private}.private";
6764							}
6765	492	50				646	next if $disabled;
6766
6767	492					1041	my $rule = {
6768							src => $src,
6769							dst => $dst,
6770							prt => $prt,
6771							rule => $unexpanded
6772							};
6773	492	100				669	$rule->{stateless} = 1 if $stateless;
6774	492	100				660	$rule->{deny} = 1 if $deny;
6775	492	100				637	$rule->{src_range} = $src_range if $src_range;
6776	492	100				988	$rule->{log} = $log if $log;
6777	492	100				666	$rule->{orig_prt} = $orig_prt if $orig_prt;
6778	492	50				1036	$rule->{oneway} = 1 if $flags->{oneway};
6779	492	50				645	$rule->{no_check_supernet_rules} = 1
6780							if $flags->{no_check_supernet_rules};
6781	492	50				668	$rule->{stateless_icmp} = 1
6782							if $flags->{stateless_icmp};
6783
6784	492					2516	push @$result, $rule;
6785							}
6786							}
6787							}
6788							}
6789							}
6790							}
6791							}
6792	261					420	show_unenforceable($service);
6793
6794							# Result is returned indirectly using parameter $result.
6795	261					508	return;
6796							}
6797
6798							sub print_rulecount {
6799	302			302	0	260	my $count = 0;
6800	302					674	for my $type ('deny', 'supernet', 'permit') {
6801	906 834 906					1023 1305 1266	$count += grep { not $_->{deleted} } @{ $expanded_rules{$type} };
6802							}
6803	302					651	info("Expanded rule count: $count");
6804	302					284	return;
6805							}
6806
6807							sub split_expanded_rule_types {
6808	315			315	0	296	my ($rules_aref) = @_;
6809
6810	315					241	my (@deny, @permit, @supernet);
6811
6812	315					380	for my $rule (@$rules_aref) {
6813	492	100 100	100			1713	if ($rule->{deny}) {
6814	2					3	push @deny, $rule;
6815							}
6816							elsif ($rule->{src}->{is_supernet} \|\| $rule->{dst}->{is_supernet}) {
6817	125					188	push @supernet, $rule;
6818							}
6819							else {
6820	365					494	push @permit, $rule;
6821							}
6822							}
6823
6824	315					1274	%expanded_rules = (deny => \@deny,
6825							permit => \@permit,
6826							supernet => \@supernet);
6827	315					442	return;
6828							}
6829
6830							sub expand_services {
6831	315			315	0	328	my ($convert_hosts) = @_;
6832	315	50				693	convert_hosts if $convert_hosts;
6833	315					404	progress('Expanding services');
6834
6835	315					449	collect_log();
6836	315					354	my $expanded_rules_aref = [];
6837
6838							# Sort by service name to make output deterministic.
6839	315					647	for my $key (sort keys %services) {
6840	261					337	my $service = $services{$key};
6841	261					290	my $name = $service->{name};
6842
6843							# Substitute service name by service object.
6844	261	100				460	if (my $overlaps = $service->{overlaps}) {
6845	4					8	my @pobjects;
6846	4					6	for my $pair (@$overlaps) {
6847	4					6	my ($type, $oname) = @$pair;
6848	4	50 50				15	if (! $type eq 'service') {
6849	0					0	err_msg "Unexpected type '$type' in attribute 'overlaps'",
6850							" of $name";
6851							}
6852							elsif (my $other = $services{$oname}) {
6853	4					12	push(@pobjects, $other);
6854							}
6855							else {
6856	0					0	warn_msg("Unknown $type:$oname in attribute 'overlaps'",
6857							" of $name");
6858							}
6859							}
6860	4					7	$service->{overlaps} = \@pobjects;
6861							}
6862
6863							# Attribute "visible" is known to have value "" or "name".
6864							# It must match prefix of some owner name.
6865							# Change value to regex to simplify tests: # name* -> /^name.*$/
6866	261	50				443	if (my $visible = $service->{visible}) {
6867	0	0				0	if (my ($prefix) = ($visible =~ /^ (\S) [] $/x)) {
6868	0	0				0	if ($prefix) {
6869	0 0	0				0 0	if (not grep { /^$prefix/ } keys %owners) {
6870	0					0	warn_msg("Attribute 'visible' of $name doesn't match",
6871							" any owner");
6872							}
6873							}
6874	0					0	$service->{visible} = qr/^$prefix.*$/;
6875							}
6876							}
6877
6878							# Don't convert hosts in user objects here.
6879							# This will be done when expanding 'user' inside a rule.
6880	261					596	$service->{user} = expand_group($service->{user}, "user of $name");
6881	261					638	expand_rules($service, $expanded_rules_aref, $convert_hosts);
6882							}
6883
6884	315					484	warn_useless_unenforceable();
6885	315					487	info("Expanded rule count: ", scalar @$expanded_rules_aref);
6886
6887	315					392	progress('Preparing optimization');
6888	315					754	add_rules($expanded_rules_aref);
6889	492					873	info("Expanded rule count: ",
6890	315					413	scalar grep { !$_->{deleted} } @$expanded_rules_aref);
6891	315					432	show_deleted_rules1();
6892
6893							# Set attribute {is_supernet} before calling split_expanded_rule_types.
6894	315					399	find_subnets_in_nat_domain();
6895	315					444	split_expanded_rule_types($expanded_rules_aref);
6896	315					349	return;
6897							}
6898
6899							# For each device, find the IP address which is used
6900							# to manage the device from a central policy distribution point.
6901							# This address is added as a comment line to each generated code file.
6902							# This is to be used later when approving the generated code file.
6903							sub set_policy_distribution_ip {
6904	226			226	0	294	progress('Setting policy distribution IP');
6905
6906							# Find all TCP ranges which include port 22 and 23.
6907	429					1014	my @admin_tcp_keys = grep({
6908	226					469	my ($p1, $p2) = split(':', $_);
6909	429	100	100 100			2062	$p1 <= 22 && 22 <= $p2 \|\| $p1 <= 23 && 23 <= $p2;
6910							}
6911	226					197	keys %{ $prt_hash{tcp} });
6912	226 226					274 408	my @prt_list = (@{ $prt_hash{tcp} }{@admin_tcp_keys}, $prt_hash{ip});
6913
6914							# Mapping from policy distribution host to subnets, networks and
6915							# aggregates that include this host.
6916	226					183	my %host2pdp_src;
6917							my $get_pdp_src = sub {
6918	10			10		9	my ($host) = @_;
6919	10					8	my $pdp_src;
6920	10	100				27	if ($pdp_src = $host2pdp_src{$host}) {
6921	1					1	return $pdp_src;
6922							}
6923	9 9 9					9 17 12	for my $pdp (map { $_ } @{ $host->{subnets} }) {
6924	9					16	while ($pdp) {
6925	18					24	push @$pdp_src, $pdp;
6926	18					35	$pdp = $pdp->{up};
6927							}
6928							}
6929	9					22	return $host2pdp_src{$host} = $pdp_src;
6930	226					645	};
6931	226					331	for my $router (@managed_routers, @routing_only_routers) {
6932	365	100				789	my $pdp = $router->{policy_distribution_point} or next;
6933	10	50				20	next if $router->{orig_router};
6934
6935	10					12	my %found_interfaces;
6936	10					16	my $no_nat_set = $pdp->{network}->{nat_domain}->{no_nat_set};
6937	10					18	my $pdp_src = $get_pdp_src->($pdp);
6938	10					12	my $stateless = '';
6939	10					9	my $deny = '';
6940	10					11	my $src_range = $prt_ip;
6941	10					12	for my $src (@$pdp_src) {
6942	20	100				63	my $sub_rule_tree =
6943							$rule_tree{$stateless}->{$deny}->{$src_range}->{$src} or next;
6944
6945							# Find interfaces where some rule permits management traffic.
6946	8 8					7 14	for my $interface (@{ $router->{interfaces} }) {
6947
6948							# Loadbalancer VIP can't be used to access device.
6949	18	50				30	next if $interface->{vip};
6950
6951	18					20	for my $prt (@prt_list) {
6952	54	100				136	$sub_rule_tree->{$interface}->{$prt} or next;
6953	9					24	$found_interfaces{$interface} = $interface;
6954							}
6955							}
6956							}
6957	10					11	my @result;
6958
6959							# Ready, if exactly one management interface was found.
6960	10	100				27	if (keys %found_interfaces == 1) {
6961	7					10	@result = values %found_interfaces;
6962							}
6963							else {
6964
6965							# debug("$router->{name}: ", scalar keys %found_interfaces);
6966	3					5	my @front = path_auto_interfaces($router, $pdp);
6967
6968							# If multiple management interfaces were found, take that which is
6969							# directed to policy_distribution_point.
6970	3					5	for my $front (@front) {
6971	4	100				11	if ($found_interfaces{$front}) {
6972	2					2	push @result, $front;
6973							}
6974							}
6975
6976							# Take all management interfaces.
6977							# Preserve original order of router interfaces.
6978	3	100				6	if (! @result) {
6979	2 4 2					2 10 3	@result = grep { $found_interfaces{$_} } @{ $router->{interfaces} };
6980							}
6981
6982							# Don't set {admin_ip} if no address is found.
6983							# Warning is printed below.
6984	3	100				9	next if not @result;
6985							}
6986
6987							# Prefer loopback interface if available.
6988	9					23	$router->{admin_ip} = [
6989	1		50 50			8	map { print_ip((address($_, $no_nat_set))->[0]) }
6990	8					14	sort { ($b->{loopback} \|\| '') cmp($a->{loopback} \|\| '') } @result
6991							];
6992							}
6993	226					241	my %seen;
6994							my @unreachable;
6995	226					268	for my $router (@managed_routers, @routing_only_routers) {
6996	365	100				655	next if $seen{$router};
6997	364	100				693	next if !$router->{policy_distribution_point};
6998	9	50				18	next if $router->{orig_router};
6999	9	100				16	if (my $vrf_members = $router->{vrf_members}) {
7000	1					2	for my $member (@$vrf_members) {
7001	1	50				5	if (!$member->{admin_ip}) {
7002	1					3	push(@unreachable,
7003							"some VRF of router:$router->{device_name}");
7004	1					1	last;
7005							}
7006							}
7007
7008							# Print VRF instance with known admin_ip first.
7009	1	0				5	$router->{vrf_members} = [
7010							sort {
7011	1					2	!$a->{admin_ip} <=> !$b->{admin_ip}
7012							\|\| $a->{name} cmp $b->{name}
7013							} @$vrf_members
7014							];
7015	1					4	$seen{$_} = 1 for @$vrf_members;
7016							}
7017							else {
7018	8	50				15	$router->{admin_ip}
7019							or push @unreachable, $router->{name};
7020	8					22	$seen{$router} = 1;
7021							}
7022							}
7023	226	100				381	if (@unreachable) {
7024	1	50				2	if (@unreachable > 4) {
7025	0					0	splice(@unreachable, 3, @unreachable - 3, '...');
7026							}
7027	1					3	my $list = join("\n - ", @unreachable);
7028	1					2	warn_msg (
7029							"Missing rules to reach devices from policy_distribution_point:\n",
7030							" - ", $list);
7031							}
7032	226					983	return;
7033							}
7034
7035							##############################################################################
7036							# Distribute owner, identify service owner
7037							##############################################################################
7038
7039							sub propagate_owners {
7040	311			311	0	274	my %zone_got_net_owners;
7041							my %clusters;
7042							ZONE:
7043	311					327	for my $zone (@zones) {
7044	824	100				1242	if (my $cluster = $zone->{zone_cluster}) {
7045	44					73	$clusters{$cluster} = $cluster;
7046							}
7047
7048							# If an explicit owner was set, it has been set for
7049							# the whole cluster in link_aggregates.
7050	824	100				1449	next if $zone->{owner};
7051
7052							# Inversed inheritance: If a zone has no direct owner and if
7053							# all contained real toplevel networks have the same owner,
7054							# then set owner of this zone to the one owner.
7055	815					577	my $owner;
7056	815 815					595 927	for my $network (@{ $zone->{networks} }) {
7057	807	50				1206	next if $network->{ip} eq 'tunnel';
7058	807					655	my $net_owner = $network->{owner};
7059	807	100				1599	next ZONE if not $net_owner;
7060	10	100				16	if ($owner) {
7061	1	50				3	next ZONE if $net_owner ne $owner;
7062							}
7063							else {
7064	9					14	$owner = $net_owner;
7065							}
7066							}
7067	17	100				37	if ($owner) {
7068							# debug("Inversed inherit: $zone->{name} $owner->{name}");
7069	8					8	$zone->{owner} = $owner;
7070	8					17	$zone_got_net_owners{$zone} = 1;
7071							}
7072							}
7073
7074							# Check for consistent implicit owners of zone clusters.
7075							# Implicit owner from networks is only valid, if the same owner
7076							# is found for all zones of cluster.
7077	311					528	for my $cluster (values %clusters) {
7078	18 44	50				23 97	my @implicit_owner_zones = grep { $zone_got_net_owners{$_} } @$cluster
7079							or next;
7080	0	0	0			0	if (
7081							!(
7082	0					0	@implicit_owner_zones == @$cluster
7083							&& equal(map { $_->{owner} } @implicit_owner_zones)
7084							)
7085							)
7086							{
7087	0					0	$_->{owner} = undef for @implicit_owner_zones;
7088
7089							# debug("Reset owner");
7090							# debug($_->{name}) for @implicit_owner_zones;
7091							}
7092							}
7093
7094							# A zone can be part of multiple areas.
7095							# Find the smallest enclosing area.
7096	311					267	my %zone2area;
7097	311					337	for my $zone (@zones) {
7098	824 824	100				606 2228	my @areas = values %{ $zone->{areas} } or next;
7099	82 32 32 32					92 27 33 40	@areas = sort { @{ $a->{zones} } <=> @{ $b->{zones} } } @areas;
7100	82					162	$zone2area{$zone} = $areas[0];
7101							}
7102
7103							# Build tree from inheritance relation:
7104							# area -> [area\|zone, ..]
7105							# zone -> [network, ..]
7106							# network -> [network, ..]
7107							# network -> [host\|interface, ..]
7108	311					307	my %tree;
7109							my %is_child;
7110	0					0	my %ref2obj;
7111							my $add_node = sub {
7112	1697			1697		1503	my ($super, $sub) = @_;
7113	1697 1697					1189 3132	push @{ $tree{$super} }, $sub;
7114	1697					2517	$is_child{$sub} = 1;
7115	1697					2138	$ref2obj{$sub} = $sub;
7116	1697					2923	$ref2obj{$super} = $super;
7117	311					988	};
7118
7119							# Find subset relation between areas.
7120	311					404	for my $area (@areas) {
7121	59	100				133	if (my $super = $area->{subset_of}) {
7122	16					27	$add_node->($super, $area);
7123							}
7124							}
7125
7126							# Find direct subset relation between areas and zones.
7127	311					352	for my $area (@areas) {
7128	59 59					56 77	for my $zone (@{ $area->{zones} }) {
7129	110	100				258	if ($zone2area{$zone} eq $area) {
7130	82					101	$add_node->($area, $zone);
7131							}
7132							}
7133							}
7134
7135							# Find subset relation between networks and hosts/interfaces.
7136							my $add_hosts = sub {
7137	1007			1007		789	my ($network) = @_;
7138	1007 1007					716 1362	for my $host (@{ $network->{hosts} }) {
7139	149					173	$add_node->($network, $host);
7140							}
7141	1007 1007					818 1120	for my $interface (@{ $network->{interfaces} }) {
7142	1454					1233	my $router = $interface->{router};
7143	1454	100	100			3724	if (!($router->{managed} \|\| $router->{routing_only})) {
7144	443					550	$add_node->($network, $interface);
7145							}
7146							}
7147	311					791	};
7148
7149							# Find subset relation between networks and networks.
7150	311					272	my $add_subnets;
7151							$add_subnets = sub {
7152	1007			1007		818	my ($network) = @_;
7153	1007					1087	$add_hosts->($network);
7154	1007	100				2637	my $subnets = $network->{networks} or return;
7155	50					76	for my $subnet (@$subnets) {
7156	52					59	$add_node->($network, $subnet);
7157	52					118	$add_subnets->($subnet);
7158							}
7159	311					726	};
7160
7161							# Find subset relation between zones and networks.
7162	311					344	for my $zone (@zones) {
7163	824 824					636 964	for my $network (@{ $zone->{networks} }) {
7164	955					1114	$add_node->($zone, $network);
7165	955					1077	$add_subnets->($network);
7166							}
7167							}
7168
7169							# Find root nodes.
7170	775					1321	my @root_nodes =
7171	311 1330					722 1785	sort by_name map { $ref2obj{$_} } grep { not $is_child{$_} } keys %tree;
7172
7173							# owner is extended by e_owner at node.
7174							# owner->[[node, e_owner, .. ], .. ]
7175	311					377	my %extended;
7176
7177							# upper_owner: owner object without attribute extend_only or undef
7178							# extend: a list of owners with attribute extend
7179							# extend_only: a list of owners with attribute extend_only
7180							my $inherit;
7181							$inherit = sub {
7182	2472			2472		2410	my ($node, $upper_owner, $upper_node, $extend, $extend_only) = @_;
7183	2472					2112	my $owner = $node->{owner};
7184	2472	100				2643	if (!$owner) {
7185	2406					2539	$node->{owner} = $upper_owner;
7186							}
7187							else {
7188	66					66	$owner->{is_used} = 1;
7189	66	100				102	if ($upper_owner) {
7190	36	100				69	if ($owner eq $upper_owner) {
7191	13	100				26	if (! $zone_got_net_owners{$upper_node})
7192							{
7193	5					23	warn_msg("Useless $owner->{name} at $node->{name},\n",
7194							" it was already inherited from",
7195							" $upper_node->{name}");
7196							}
7197							}
7198							else {
7199	23	100				43	if ($upper_owner->{extend}) {
7200	3					5	$extend = [ $upper_owner, @$extend ];
7201							}
7202							}
7203							}
7204	66					78	my @extend_list = ($node);
7205	66	50				99	push @extend_list, @$extend if $extend;
7206	66	50				94	push @extend_list, @$extend_only if $extend_only;
7207	66 66					48 138	push @{ $extended{$owner} }, \@extend_list;
7208							}
7209	2472	100	67			3908	if (!$owner \|\| !$owner->{extend_only}) {
7210	2466	100				3514	if (my $upper_extend = $extend_only->[0]) {
7211	20					22	$node->{extended_owner} = $upper_extend;
7212							}
7213							}
7214
7215	2472	100 100	100			5197	if ($owner && $owner->{extend_only}) {
7216	6					7	$extend_only = [ $owner, @$extend_only ];
7217	6					6	$upper_owner = undef;
7218	6					6	$upper_node = undef;
7219							}
7220							elsif($owner) {
7221	60					47	$upper_owner = $owner;
7222	60					53	$upper_node = $node;
7223							}
7224	2472	100				6684	my $childs = $tree{$node} or return;
7225	1330					1318	for my $child (@$childs) {
7226	1697					3042	$inherit->($child, $upper_owner, $upper_node, $extend,
7227							$extend_only);
7228							}
7229	311					1277	};
7230	311					379	for my $node (@root_nodes) {
7231	775					1219	$inherit->($node, undef, undef, [], []);
7232							}
7233
7234							# Collect extended owners and check for inconsistent extensions.
7235							# Check owner with attribute {show_all}.
7236	311					783	for my $owner (sort by_name values %owners) {
7237	48		100			108	my $aref = $extended{$owner} \|\| [];
7238	48					44	my $node1;
7239							my $ext1;
7240	0					0	my $combined;
7241	48					51	for my $node_ext (@$aref) {
7242	66					65	my $node = shift @$node_ext;
7243	66	100				118	next if $zone_got_net_owners{$node};
7244	58					46	my $ext = $node_ext;
7245	58	100				74	if ($node1) {
7246	14					19	for my $owner_list ($ext1, $ext) {
7247	28	100				60	my ($other, $owner_node, $other_node) =
7248							$owner_list eq $ext
7249							? ($ext1, $node, $node1)
7250							: ($ext, $node1, $node);
7251	28					46	for my $e_owner (@$owner_list) {
7252	6	100				13	next if $e_owner->{extend_unbounded};
7253	5 6	50				5 15	next if grep { $e_owner eq $_ } @$other;
7254	5					23	warn_msg("$owner->{name}",
7255							" is extended by $e_owner->{name}\n",
7256							" - only at $owner_node->{name}\n",
7257							" - but not at $other_node->{name}");
7258							}
7259							}
7260	14					30	$combined = [ @$ext, @$combined ];
7261							}
7262							else {
7263	44					33	$combined = $ext;
7264	44					75	($node1, $ext1) = ($node, $ext);
7265							}
7266							}
7267	48	100	100			155	if ($combined && @$combined) {
7268	10					15	$owner->{extended_by} = [ unique @$combined ];
7269							}
7270	48	100				117	if ($owner->{show_all}) {
7271	1					1	my @invalid;
7272	1					1	for my $node (@root_nodes) {
7273	3		100			9	my $node_owner = $node->{owner} \|\| '';
7274	3	100				6	if ($node_owner ne $owner) {
7275	2					2	push @invalid, $node;
7276							}
7277							}
7278	1	50				2	if (@invalid) {
7279	1 2					2 4	my $missing = join("\n - ", map { $_->{name} } @invalid);
7280	1					4	err_msg("$owner->{name} has attribute 'show_all',",
7281							" but doesn't own whole topology.\n",
7282							" Missing:\n",
7283							" - $missing");
7284							}
7285							}
7286							}
7287
7288							# Handle {router_attributes}->{owner} separately.
7289							# Areas can be nested. Proceed from small to larger ones.
7290	311 28 28 28					523 26 30 41	for my $area (sort { @{ $a->{zones} } <=> @{ $b->{zones} } } @areas) {
7291	59	100				127	my $attributes = $area->{router_attributes} or next;
7292	7	50				17	my $owner = $attributes->{owner} or next;
7293	0					0	$owner->{is_used} = 1;
7294	0 0					0 0	for my $router (@{ $area->{managed_routers} }) {
7295	0	0				0	if (my $r_owner = $router->{owner}) {
7296	0	0				0	if ($r_owner eq $owner) {
7297	0					0	warn_msg(
7298							"Useless $r_owner->{name} at $router->{name},\n",
7299							" it was already inherited from $attributes->{name}");
7300							}
7301							}
7302							else {
7303	0					0	$router->{owner} = $owner;
7304							}
7305							}
7306							}
7307
7308	311					400	for my $router (@managed_routers, @routing_only_routers) {
7309	454	100				897	my $owner = $router->{owner} or next;
7310	1					2	$owner->{is_used} = 1;
7311
7312	1					2	for my $interface (get_intf($router)) {
7313
7314							# Loadbalancer interface with {vip} can have dedicated owner.
7315	3		67			9	$interface->{owner} \|\|= $owner;
7316							}
7317							}
7318
7319							# Propagate owner of loopback interface to loopback network
7320							# and loopback zone.
7321	311					369	for my $router (@routers) {
7322	634		100			1245	my $managed = $router->{managed} \|\| $router->{routing_only};
7323	634 634					470 757	for my $interface (@{ $router->{interfaces} }) {
7324	1498	100				2664	$interface->{loopback} or next;
7325	39	100				82	my $owner = $interface->{owner} or next;
7326	1					1	my $network = $interface->{network};
7327	1					2	$network->{owner} = $owner;
7328	1	50				2	$network->{zone}->{owner} = $owner if $managed;
7329
7330							# Mark dedicated owner of {vip} interface, which is also a
7331							# loopback interface.
7332	1					2	$owner->{is_used} = 1;
7333							}
7334							}
7335
7336							# Inherit owner from enclosing network or zone to aggregate.
7337	311					341	for my $zone (@zones) {
7338	824 824					617 1536	for my $aggregate (values %{ $zone->{ipmask2aggregate} }) {
7339	49	50				96	next if $aggregate->{owner};
7340	49					41	my $up = $aggregate;
7341	49					100	while ($up = $up->{up}) {
7342	17	100				31	last if !$up->{is_aggregate};
7343							}
7344	49	100				123	$aggregate->{owner} = ($up ? $up : $zone)->{owner};
7345							}
7346							}
7347	311					748	return;
7348							}
7349
7350							sub expand_auto_intf {
7351	514			514	0	474	my ($src_aref, $dst_aref) = @_;
7352	514					861	for (my $i = 0 ; $i < @$src_aref ; $i++) {
7353	703					586	my $src = $src_aref->[$i];
7354	703	100				774	next if not is_autointerface($src);
7355	23					21	my @new;
7356	23					27	for my $dst (@$dst_aref) {
7357	26					40	push @new, path_auto_interfaces($src, $dst);
7358							}
7359
7360							# Substitute auto interface by real interface(s).
7361							# Possible duplicate elements in @new are removed later.
7362	23					67	splice(@$src_aref, $i, 1, @new);
7363							}
7364	514					520	return;
7365							}
7366
7367							my %unknown2services;
7368							my %unknown2unknown;
7369
7370							sub show_unknown_owners {
7371	311			311	0	495	for my $polices (values %unknown2services) {
7372	0					0	$polices = join(',', sort @$polices);
7373							}
7374	311	50				667	my $print =
7375							$config{check_service_unknown_owner} eq 'warn'
7376							? \&warn_msg
7377							: \&err_msg;
7378							UNKNOWN:
7379	311					492	for my $obj (values %unknown2unknown) {
7380	0					0	my $up = $obj;
7381	0					0	while ($up = $up->{up}) {
7382	0	0	0			0	if ( $unknown2services{$up}
7383							and $unknown2services{$obj} eq $unknown2services{$up})
7384							{
7385	0					0	next UNKNOWN;
7386							}
7387							}
7388	0					0	$print->("Unknown owner for $obj->{name} in $unknown2services{$obj}");
7389							}
7390	311					476	%unknown2services = %unknown2unknown = ();
7391	311					299	return;
7392							}
7393
7394							sub set_service_owner {
7395	311			311	0	390	progress('Checking service owner');
7396
7397	311					419	propagate_owners();
7398
7399	311					627	for my $key (sort keys %services) {
7400	257					378	my $service = $services{$key};
7401	257					270	my $sname = $service->{name};
7402
7403	257					647	my $users = expand_group($service->{user}, "user of $sname");
7404
7405							# Non 'user' objects.
7406	257					241	my @objects;
7407
7408							# Check, if service contains a coupling rule with only "user" elements.
7409	257					223	my $is_coupling = 0;
7410
7411	257 257					221 362	for my $rule (@{ $service->{rules} }) {
7412	291					302	my $has_user = $rule->{has_user};
7413	291	100				462	if ($has_user eq 'both') {
7414	11					12	$is_coupling = 1;
7415	11					19	next;
7416							}
7417	280					287	for my $what (qw(src dst)) {
7418	560	100				902	next if $what eq $has_user;
7419	280					648	push(@objects,
7420	280					219	@{ expand_group($rule->{$what}, "$what of $sname") });
7421							}
7422							}
7423
7424							# Expand auto interface of objects in rules to set of real interfaces.
7425	257					432	expand_auto_intf(\@objects, $users);
7426
7427							# Expand auto interfaces in users with counterpart in
7428							# - users and objects
7429							# - only users
7430							# - only objects.
7431							# Add elements of expanded users to objects.
7432	257	100				363	if ($is_coupling) {
7433	11	50				21	if (@objects) {
7434	0					0	expand_auto_intf($users, [ @objects, @$users ]);
7435							}
7436							else {
7437	11					19	expand_auto_intf($users, $users);
7438							}
7439	11					14	push @objects, @$users;
7440							}
7441							else {
7442	246					311	expand_auto_intf($users, \@objects);
7443							}
7444
7445							# Collect service owners and unknown owners;
7446	257					232	my $service_owners;
7447							my $unknown_owners;
7448
7449	257					368	for my $obj (unique @objects) {
7450	307					319	my $owner = $obj->{owner};
7451	307	100				741	if ($owner) {
7452	15					35	$service_owners->{$owner} = $owner;
7453							}
7454							else {
7455	292					657	$unknown_owners->{$obj} = $obj;
7456							}
7457							}
7458
7459	257					547	$service->{owners} = [ values %$service_owners ];
7460
7461							# Check for redundant service owner.
7462							# Allow dedicated service owner, if we have multiple owners
7463							# from @objects.
7464	257	100				474	if (my $sub_owner = $service->{sub_owner}) {
7465	1					1	$sub_owner->{is_used} = 1;
7466	1	50	33			3	(keys %$service_owners == 1 && $service_owners->{$sub_owner}) and
7467							warn_msg("Useless $sub_owner->{name} at $service->{name}");
7468							}
7469
7470							# Check for multiple owners.
7471	257	100				397	my $multi_count =
7472							$is_coupling
7473							? 1
7474							: values %$service_owners;
7475	257	100	75			924	if ($multi_count > 1 xor $service->{multi_owner}) {
7476	1	50				3	if ($service->{multi_owner}) {
7477	0					0	warn_msg("Useless use of attribute 'multi_owner' at $sname");
7478							}
7479							else {
7480							my $print =
7481							$config{check_service_multi_owner}
7482							? $config{check_service_multi_owner} eq 'warn'
7483							? \&warn_msg
7484							: \&err_msg
7485	1 0	50 50		0		4 0	: sub { };
7486	2					10	my @names =
7487	1					2	sort(map { ($_->{name} =~ /^owner:(.*)/)[0] }
7488							values %$service_owners);
7489	1					5	$print->("$sname has multiple owners:\n " . join(', ', @names));
7490							}
7491							}
7492
7493							# Check for unknown owners.
7494	257	100	33			1353	if (($unknown_owners and keys %$unknown_owners)
7495							xor $service->{unknown_owner})
7496							{
7497	246	50				319	if ($service->{unknown_owner}) {
7498	0					0	warn_msg("Useless use of attribute 'unknown_owner' at $sname");
7499							}
7500							else {
7501	246	50				1044	if ($config{check_service_unknown_owner}) {
7502	0					0	for my $obj (values %$unknown_owners) {
7503	0					0	$unknown2unknown{$obj} = $obj;
7504	0 0					0 0	push @{ $unknown2services{$obj} }, $sname;
7505							}
7506							}
7507							}
7508							}
7509							}
7510
7511							# Show unused owners.
7512							# Remove attribute {is_used}, which isn't needed any longer.
7513	311					557	for my $owner (values %owners) {
7514	48	100				108	delete $owner->{is_used} or warn_msg("Unused $owner->{name}");
7515							}
7516
7517	311					450	show_unknown_owners();
7518	311					260	return;
7519							}
7520
7521							##############################################################################
7522							# Distribute NAT bindings
7523							##############################################################################
7524
7525							# NAT Set: a set of NAT tags which are effective at some location.
7526							# NAT Domain: a maximal area of the topology (a set of connected networks)
7527							# where the NAT set is identical at each network.
7528							sub set_natdomain;
7529
7530							sub set_natdomain {
7531	1243			1243	0	1173	my ($network, $domain, $in_interface) = @_;
7532
7533							# Found a loop inside a NAT domain.
7534	1243	100				2013	return if $network->{nat_domain};
7535
7536							# debug("$domain->{name}: $network->{name}");
7537	1112					1511	$network->{nat_domain} = $domain;
7538	1112 1112					835 1379	push @{ $domain->{networks} }, $network;
7539	1112 1112					931 1343	for my $interface (@{ $network->{interfaces} }) {
7540
7541							# Ignore interface where we reached this network.
7542	1630	100				3394	next if $interface eq $in_interface;
7543
7544	961	100				1399	next if $interface->{main_interface};
7545
7546							# debug("IN $interface->{name}");
7547	883					630	my $err_seen;
7548	883		67			2112	my $nat_tags = $interface->{bind_nat} \|\| $bind_nat0;
7549	883					757	my $router = $interface->{router};
7550	883 883					657 1077	for my $out_interface (@{ $router->{interfaces} }) {
7551
7552							# Don't process interface where we reached this router.
7553	2128	100				4217	next if $out_interface eq $interface;
7554
7555							# Current NAT domain continues behind $out_interface.
7556	1245		67			2827	my $out_nat_tags = $out_interface->{bind_nat} \|\| $bind_nat0;
7557	1245	100				1487	if (aref_eq($out_nat_tags, $nat_tags)) {
7558
7559							# Put check for active path inside this loop, because
7560							# 1. we must enter each router from each side to detect
7561							# all inconsistencies,
7562							# 2. we need the check at all to prevent deep recursion.
7563							#
7564							# 'local' declaration restores previous value on block exit.
7565	965	100				1426	next if $router->{active_path};
7566	905					1109	local $router->{active_path} = 1;
7567
7568	905	100				1377	next if $out_interface->{main_interface};
7569
7570	800					705	my $next_net = $out_interface->{network};
7571	800					1322	set_natdomain($next_net, $domain, $out_interface);
7572							}
7573
7574							# New NAT domain starts at some interface of current router.
7575							# Remember NAT tag of current domain.
7576							else {
7577
7578							# If one router is connected to the same NAT domain
7579							# by different interfaces, all interfaces must have
7580							# the same NAT binding. (This occurs only in loops).
7581	280	100				604	if (my $old_nat_tags = $router->{nat_tags}->{$domain}) {
7582	79	100				87	if (not aref_eq($old_nat_tags, $nat_tags)) {
7583	1	50				5	next if $err_seen->{$old_nat_tags}->{$nat_tags}++;
7584	1		50			4	my $old_names = join(',', @$old_nat_tags) \|\| '(none)';
7585	1		50			5	my $new_names = join(',', @$nat_tags) \|\| '(none)';
7586	1					5	err_msg
7587							"Inconsistent NAT in loop at $router->{name}:\n",
7588							" nat:$old_names vs. nat:$new_names";
7589							}
7590
7591							# NAT domain and router have been linked together already.
7592	79					141	next;
7593							}
7594	201					347	$router->{nat_tags}->{$domain} = $nat_tags;
7595							# debug("OUT $out_interface->{name}");
7596	201 201					152 233	push @{ $domain->{routers} }, $router;
7597	201 201					173 442	push @{ $router->{nat_domains} }, $domain;
7598							}
7599							}
7600							}
7601	1112					2185	return;
7602							}
7603
7604							my @natdomains;
7605
7606							# Distribute NAT tags from NAT domain to NAT domain.
7607							# Returns
7608							# - undef on success
7609							# - aref of routers, if invalid path was found in loop.
7610							sub distribute_nat1 {
7611	119			119	0	129	my ($domain, $nat_tag, $nat_tags2multi, $in_router) = @_;
7612
7613							# debug "nat:$nat_tag at $domain->{name} from $in_router->{name}";
7614	119	100				196	if ($domain->{active_path}) {
7615
7616							# debug("$domain->{name} loop");
7617							# Found a loop
7618	1					6	return;
7619							}
7620
7621							# Tag is already there.
7622	118					108	my $nat_set = $domain->{nat_set};
7623	118	100				198	return if $nat_set->{$nat_tag};
7624
7625							# Must not enter one NAT domain at different routers with
7626							# different elements of grouped NAT tags.
7627	104	100				194	if (my $aref = $nat_tags2multi->{$nat_tag}) {
7628	42					41	for my $multi_href (@$aref) {
7629	51					107	for my $nat_tag2 (sort keys %$multi_href) {
7630	119	100				236	if ($nat_set->{$nat_tag2}) {
7631	2					9	err_msg("Grouped NAT tags '$nat_tag2' and '$nat_tag'",
7632							" must not both be active inside $domain->{name}");
7633							}
7634							}
7635							}
7636							}
7637
7638							# Add tag.
7639							# Use a hash to prevent duplicate entries.
7640	104					152	$nat_set->{$nat_tag} = 1;
7641
7642							# Network which has translation with tag $nat_tag must not be located
7643							# in area where this tag is effective.
7644	104 104					89 147	for my $network (@{ $domain->{networks} }) {
7645	133	100				280	my $nat = $network->{nat} or next;
7646	6	100				13	$nat->{$nat_tag} or next;
7647	1					8	err_msg("$network->{name} is translated by $nat_tag,\n",
7648							" but is located inside the translation domain of $nat_tag.\n",
7649							" Probably $nat_tag was bound to wrong interface",
7650							" at $in_router->{name}.");
7651
7652							# Show error message only once.
7653	1					2	last;
7654							}
7655
7656							# Activate loop detection.
7657	104					162	local $in_router->{active_path} = 1;
7658	104					124	local $domain->{active_path} = 1;
7659
7660							# Distribute NAT tag to adjacent NAT domains.
7661	104 104					91 127	for my $router (@{ $domain->{routers} }) {
7662	136	100				321	next if $router eq $in_router;
7663	33					37	my $in_nat_tags = $router->{nat_tags}->{$domain};
7664
7665							# Found another interface with same NAT binding.
7666							# This stops effect of current NAT tag.
7667	33 14	100				50 42	next if grep { $_ eq $nat_tag } @$in_nat_tags;
7668
7669							# Traverse loop twice to prevent inherited errors.
7670							# Check for recursive and duplicate NAT.
7671	23 23					20 30	for my $out_domain (@{ $router->{nat_domains} }) {
7672	51	100				85	next if $out_domain eq $domain;
7673	29					40	my $out_nat_tags = $router->{nat_tags}->{$out_domain};
7674
7675							# Must not apply one NAT tag multiple times in a row.
7676	29 25	100				32 70	if (grep { $_ eq $nat_tag } @$out_nat_tags) {
7677
7678							# Check for recursive NAT in loop.
7679	3	100				6	if ($router->{active_path}) {
7680
7681							# Abort traversal and start collecting path.
7682	1					5	return [ $router ];
7683							}
7684	2					9	err_msg("nat:$nat_tag is applied twice between",
7685							" $in_router->{name} and $router->{name}");
7686							}
7687							}
7688
7689							DOMAIN:
7690	22 22					19 28	for my $out_domain (@{ $router->{nat_domains} }) {
7691	49	100				86	next if $out_domain eq $domain;
7692	27					31	my $out_nat_tags = $router->{nat_tags}->{$out_domain};
7693
7694							# Effect of current NAT tag stops if another element of
7695							# grouped NAT tags becomes active.
7696	27	100				52	if (my $aref = $nat_tags2multi->{$nat_tag}) {
7697	21					21	for my $href (@$aref) {
7698	22					25	for my $nat_tag2 (@$out_nat_tags) {
7699	20	50				26	next if $nat_tag2 eq $nat_tag;
7700	20	100				39	next if !$href->{$nat_tag2};
7701
7702							# debug "- $nat_tag2";
7703							# Prevent transition from dynamic to
7704							# static NAT.
7705	16					14	my $nat_info = $href->{$nat_tag};
7706	16					16	my $next_info = $href->{$nat_tag2};
7707
7708							# Use $next_info->{name} and not $nat_info->{name}
7709							# because $nat_info may show wrong network,
7710							# because we combined different hidden networks into
7711							# $nat_tags2multi.
7712	16	100 50				27	if ($nat_info->{hidden}) {
7713	3					14	err_msg("Must not change hidden nat:$nat_tag",
7714							" using nat:$nat_tag2\n",
7715							" for $next_info->{name}",
7716							" at $router->{name}");
7717							}
7718							elsif ($nat_info->{dynamic}) {
7719	0	0				0	if(!($next_info->{dynamic})) {
7720	0					0	err_msg("Must not change dynamic nat:$nat_tag",
7721							" to static using nat:$nat_tag2\n",
7722							" for $nat_info->{name}",
7723							" at $router->{name}");
7724							}
7725							}
7726	16					46	next DOMAIN;
7727							}
7728							}
7729							}
7730
7731							# debug "Caller $domain->{name}";
7732	11	100				29	if (my $err_path = distribute_nat1($out_domain, $nat_tag,
7733							$nat_tags2multi, $router))
7734							{
7735	1					1	push @$err_path, $router;
7736	1					4	return $err_path;
7737							}
7738							}
7739							}
7740	102					286	return;
7741							}
7742
7743							sub distribute_nat {
7744	108			108	0	137	my ($domain, $nat_tag, $nat_tags2multi, $in_router) = @_;
7745	108	100				138	if (my $err_path = distribute_nat1($domain, $nat_tag,
7746							$nat_tags2multi, $in_router)) {
7747	1					1	push @$err_path, $in_router;
7748	3					6	err_msg("nat:$nat_tag is applied recursively in loop at this path:\n",
7749	1					4	" - ", join("\n - ", map { $_->{name} } reverse @$err_path));
7750							}
7751	108					108	return;
7752							}
7753
7754							sub distribute_nat_info {
7755	332			332	0	474	progress('Distributing NAT');
7756
7757							# Mapping from nat_tag to boolean. Is false if all NAT mappings map
7758							# to hidden.
7759	332					269	my %has_non_hidden;
7760
7761	332					366	for my $network (@networks) {
7762	1165	100				1978	my $href = $network->{nat} or next;
7763	109					178	for my $nat_tag (keys %$href) {
7764	128					131	my $nat_network = $href->{$nat_tag};
7765	128	100				219	if (!$nat_network->{hidden}) {
7766	91					192	$has_non_hidden{$nat_tag} = 1;
7767							}
7768							}
7769							}
7770
7771							# A hash with all defined NAT tags.
7772							# It is used to check,
7773							# - if all NAT definitions are bound and
7774							# - if all bound NAT tags are defined somewhere.
7775	332					336	my %nat_definitions;
7776
7777							# Check consistency of grouped NAT tags at one network.
7778							# If NAT tags are grouped at one network,
7779							# the same NAT tags must be used as group at all other networks.
7780							# Suppose tags A and B are used grouped.
7781							# An occurence of bind_nat = A activates NAT:A.
7782							# An successive bind_nat = B actives NAT:B, but implicitly disables NAT:A.
7783							# Hence A is disabled for all networks and therefore
7784							# this restriction is needed.
7785							# Exception:
7786							# NAT tags with "hidden" can be added to some valid set of grouped tags,
7787							# because we don't allow transition from hidden tag back to some other
7788							# (hidden) tag.
7789							#
7790							# A hash with all defined NAT tags as keys and aref of hrefs as value.
7791							# The href has those NAT tags as keys which are used together at one
7792							# network.
7793							# This is used to check,
7794							# that NAT tags are equally used grouped or solitary.
7795							my %nat_tags2multi;
7796	0					0	my %all_hidden;
7797	332					345	for my $network (@networks) {
7798	1165	100				1908	my $href = $network->{nat} or next;
7799							# debug $network->{name}, " href=", join(',', sort keys %$href);
7800
7801							# Print error message only once per network.
7802	109					80	my $err_shown;
7803							my $show_err = sub {
7804	5			5		6	my ($href1, $href2) = @_;
7805	5	100				8	return if $err_shown;
7806	3					7	my $tags1 = join(',', sort keys %$href1);
7807	3					5	my $name1 = $network->{name};
7808	3					8	my $tags2 = join(',', sort keys %$href2);
7809
7810							# Values are NAT entries with name of network.
7811							# Take first value deterministically.
7812	3 7					5 11	my ($name2) = sort map { $_->{name} } values %$href2;
7813	3					15	err_msg
7814							"If multiple NAT tags are used at one network,\n",
7815							" these NAT tags must be used",
7816							" equally grouped at other networks:\n",
7817							" - $name1: $tags1\n",
7818							" - $name2: $tags2";
7819	3					4	$err_shown = 1;
7820	3					4	return;
7821	109					388	};
7822
7823							NAT_TAG:
7824	109					241	for my $nat_tag (sort keys %$href) {
7825	128					160	$nat_definitions{$nat_tag} = 1;
7826	128	100				236	if (my $aref = $nat_tags2multi{$nat_tag}) {
7827
7828							# If elements have a common non hidden tag,
7829							# then only a single href is allowed.
7830	31	100				61	if ($has_non_hidden{$nat_tag}) {
7831	18					18	my $href2 = $aref->[0];
7832	18	100				28	keys_eq($href, $href2) or $show_err->($href, $href2);
7833	18					82	next NAT_TAG;
7834							}
7835
7836							# Array of hrefs has common hidden NAT tag.
7837							#
7838							# Ignore new href if it is identical to some previous one.
7839	13					14	for my $href2 (@$aref) {
7840	18	100				20	keys_eq($href, $href2) and next NAT_TAG;
7841							}
7842
7843							# Some element is non hidden, check detailed.
7844	11 56	100				18 76	if (grep { $has_non_hidden{$_} } %$href) {
7845
7846							# Check new href for consistency with previous hrefs.
7847	8					18	for my $nat_tag2 (sort keys %$href) {
7848	22	100				32	next if $nat_tag2 eq $nat_tag;
7849	14					20	for my $href2 (@$aref) {
7850
7851							# Don't check previous href with all hidden tags.
7852	25	100				42	next if $all_hidden{$href2};
7853
7854							# Non hidden tag must not occur in other href.
7855	19	100				24	if ($has_non_hidden{$nat_tag2}) {
7856	13	100				29	if ($href2->{$nat_tag2}) {
7857	1					3	$show_err->($href, $href2);
7858							next NAT_TAG
7859	1					2	}
7860							}
7861
7862							# Hidden tag must occur in all other hrefs.
7863							else {
7864	6	50				15	if (!$href2->{$nat_tag2}) {
7865	0					0	$show_err->($href, $href2);
7866							next NAT_TAG
7867	0					0	}
7868							}
7869							}
7870							}
7871							}
7872
7873							# All elements are hidden. Always ok.
7874							else {
7875
7876							# Mark this type of href for easier checks.
7877	3					5	$all_hidden{$href} = 1;
7878							}
7879
7880							# If current href and some previous href are in subset
7881							# relation, then take larger set.
7882	10					14	for my $href2 (@$aref) {
7883	14 40					19 47	my $common_size = grep { $href2->{$_ } } keys %$href;
7884	14	100 50				39	if ($common_size eq keys %$href) {
7885
7886							# Ignore new href, because it is subset.
7887	1					6	next NAT_TAG;
7888							}
7889							elsif ($common_size eq keys %$href2) {
7890
7891							# Replace previous href by new superset.
7892	0					0	$href2 = $href;
7893	0					0	next NAT_TAG;
7894							}
7895							else {
7896
7897							# Add new href below.
7898							}
7899							}
7900							}
7901	106 106					98 555	push @{ $nat_tags2multi{$nat_tag} }, $href;
7902							}
7903							}
7904
7905							# Remove single entries.
7906	332					578	for my $nat_tag (keys %nat_tags2multi) {
7907	97					106	my $aref = $nat_tags2multi{$nat_tag};
7908	97	100				157	next if @$aref > 1;
7909	91					88	my $href = $aref->[0];
7910	91	100				144	next if keys %$href > 1;
7911	59					134	delete $nat_tags2multi{$nat_tag};
7912							}
7913
7914							# Find NAT domains.
7915	332					388	for my $network (@networks) {
7916	1165	100				1696	next if $network->{is_aggregate};
7917	1112	100				1777	next if $network->{nat_domain};
7918	443					2306	(my $name = $network->{name}) =~ s/^\w+:/nat_domain:/;
7919	443					1020	my $domain = new(
7920							'nat_domain',
7921							name => $name,
7922							networks => [],
7923							routers => [],
7924							nat_set => {},
7925							);
7926	443					483	push @natdomains, $domain;
7927	443					619	set_natdomain($network, $domain, 0);
7928							}
7929
7930							# Distribute NAT tags to NAT domains.
7931	332					392	for my $domain (@natdomains) {
7932	443 443					348 736	for my $router (@{ $domain->{routers} }) {
7933	201					279	my $nat_tags = $router->{nat_tags}->{$domain};
7934							# debug "$domain->{name} $router->{name}: ", join(',', @$nat_tags);
7935
7936							# Multiple tags are bound to interface.
7937							# If some network has multiple matching NAT tags,
7938							# the resulting NAT mapping would be ambiguous.
7939	201	100				299	if (@$nat_tags >= 2) {
7940							NAT_TAG:
7941	3					3	for my $nat_tag (@$nat_tags) {
7942	5	50				9	my $aref = $nat_tags2multi{$nat_tag} or next;
7943	5					6	for my $href (@$aref) {
7944	5 10	100				5 27	my @tags = grep { $href->{$_} && $_ } @$nat_tags;
7945	5	100				14	@tags >= 2 or next;
7946	1					2	my $tags = join(',', @tags);
7947	1					1	my $nat_net = $href->{$tags[0]};
7948	1					5	err_msg("Must not bind multiple NAT tags",
7949							" '$tags' of $nat_net->{name}",
7950							" at $router->{name}");
7951
7952							# Show only first error. Otherwise we
7953							# would show the same error multiple
7954							# times.
7955	1					2	last NAT_TAG;
7956							}
7957							}
7958							}
7959	201					300	for my $nat_tag (@$nat_tags) {
7960	109	100				181	if ($nat_definitions{$nat_tag}) {
7961	108					195	distribute_nat($domain, $nat_tag, \%nat_tags2multi,
7962							$router);
7963	108					304	$nat_definitions{$nat_tag} = 'used';
7964							}
7965							else {
7966	1					4	warn_msg("Ignoring useless nat:$nat_tag",
7967							" bound at $router->{name}");
7968							}
7969							}
7970							}
7971							}
7972
7973							# Check compatibility of host/interface and network NAT.
7974							# A NAT definition for a single host/interface is only allowed,
7975							# if the network has a dynamic NAT definition.
7976	332					377	for my $network (@networks) {
7977	1165 1165 1165					859 1174 1315	for my $obj (@{ $network->{hosts} }, @{ $network->{interfaces} }) {
7978	1810	100				3414	if ($obj->{nat}) {
7979	5 5					6 10	for my $nat_tag (keys %{ $obj->{nat} }) {
7980	5					5	my $nat_network;
7981	5	50	33			23	if ( $nat_network = $network->{nat}->{$nat_tag}
7982							and $nat_network->{dynamic})
7983							{
7984	5					8	my $obj_ip = $obj->{nat}->{$nat_tag};
7985	5 5					5 9	my ($ip, $mask) = @{$nat_network}{ 'ip', 'mask' };
7986	5	50				9	if (not(match_ip($obj_ip, $ip, $mask))) {
7987	0					0	err_msg "nat:$nat_tag: $obj->{name}'s IP ",
7988							"doesn't match $network->{name}'s IP/mask";
7989							}
7990							}
7991							else {
7992	0					0	err_msg "nat:$nat_tag not allowed for ",
7993							"$obj->{name} because $network->{name} ",
7994							"doesn't have dynamic NAT definition";
7995							}
7996							}
7997							}
7998							}
7999							}
8000
8001	332					587	for my $name (keys %nat_definitions) {
8002	97	100				225	$nat_definitions{$name} eq 'used' or
8003							warn_msg("nat:$name is defined, but not bound to any interface");
8004							}
8005
8006							# Find interfaces with dynamic NAT which is applied at the same device.
8007							# This is incomatible with device with "need_protect".
8008	332					393	for my $network (@networks) {
8009	1165	100				1958	my $nat = $network->{nat} or next;
8010	109					156	for my $nat_tag (keys %$nat) {
8011	128					129	my $nat_info = $nat->{$nat_tag};
8012	128	100				221	$nat_info->{dynamic} or next;
8013	74 74					60 88	for my $interface (@{ $network->{interfaces} }) {
8014	89					75	my $intf_nat = $interface->{nat};
8015
8016							# Interface has static translation,
8017	89	100	67			171	next if $intf_nat && $intf_nat->{$nat_tag};
8018
8019	86					72	my $router = $interface->{router};
8020	86	50				237	next if !$router->{need_protect};
8021	0 0					0 0	for my $bind_intf (@{ $router->{interfaces} }) {
8022	0	0				0	my $bind = $bind_intf->{bind_nat} or next;
8023	0 0	0				0 0	grep { $_ eq $nat_tag } @$bind or next;
8024	0					0	err_msg("Must not apply dynamic NAT to $interface->{name}",
8025							" at $bind_intf->{name} of same device.\n",
8026							" This isn't supported for model",
8027							" $router->{model}->{name}.");
8028							}
8029							}
8030							}
8031							}
8032	332					505	invert_nat_set();
8033	332					543	return;
8034							}
8035
8036							sub invert_nat_set {
8037
8038							# Find NAT partitions.
8039							# NAT partitions arise, if parts of the topology are strictly
8040							# separated by crypto interfaces.
8041	332			332	0	298	my %partitions;
8042							my $mark_nat_partition;
8043							$mark_nat_partition = sub {
8044	679			679		618	my ($domain, $mark) = @_;
8045	679	100				1406	return if $partitions{$domain};
8046							# debug "$mark $domain->{name}";
8047	443					649	$partitions{$domain} = $mark;
8048	443 443					368 875	for my $router (@{ $domain->{routers} }) {
8049	201 201					155 220	for my $out_domain (@{ $router->{nat_domains} }) {
8050	437	100				1008	next if $out_domain eq $domain;
8051	236					428	$mark_nat_partition->($out_domain, $mark);
8052							}
8053							}
8054	332					1117	};
8055	332					347	my $mark = 0;
8056	332					361	for my $domain (@natdomains) {
8057	443					362	$mark++;
8058	443					575	$mark_nat_partition->($domain, $mark);
8059							}
8060
8061							# Collect NAT tags used in each partition.
8062	332					294	my %partition2tags;
8063	332					359	for my $domain (@natdomains) {
8064	443					574	my $mark = $partitions{$domain};
8065	443 443					345 554	for my $network (@{ $domain->{networks} }) {
8066	1112	100				2119	my $href = $network->{nat} or next;
8067	109					165	for my $nat_tag (keys %$href) {
8068	128					340	$partition2tags{$mark}->{$nat_tag} = 1;
8069							}
8070							}
8071							}
8072
8073							# Invert {nat_set} to {no_nat_set}
8074	332					373	for my $domain (@natdomains) {
8075	443					537	my $nat_set = delete $domain->{nat_set};
8076	443					601	my $mark = $partitions{$domain};
8077	443		100			1221	my $all_nat_set = $partition2tags{$mark} \|\|= {};
8078							# debug "$mark $domain->{name} all: ", join(',', keys %$all_nat_set);
8079	443					774	my $no_nat_set = { %$all_nat_set };
8080	443 443					554 474	delete @{$no_nat_set}{keys %$nat_set};
8081	443					1109	$domain->{no_nat_set} = $no_nat_set;
8082							# debug "$mark $domain->{name} no: ", join(',', keys %$no_nat_set);
8083							}
8084
8085							# Distribute {no_nat_set} to interfaces.
8086							# no_nat_set is needed at logical and hardware interfaces of
8087							# managed routers. Set it also for semi_managed routers to
8088							# calculate {up} relation between subnets.
8089	332					409	for my $domain (@natdomains) {
8090	443					430	my $no_nat_set = $domain->{no_nat_set};
8091	443 443					337 533	for my $network (@{ $domain->{networks} }) {
8092	1112 1112					828 1240	for my $interface (@{ $network->{interfaces} }) {
8093	1630					1372	my $router = $interface->{router};
8094	1630	100	100			3746	($router->{managed} \|\| $router->{semi_managed}) or next;
8095
8096							# debug("$domain->{name}: NAT $interface->{name}");
8097	1158					1303	$interface->{no_nat_set} = $no_nat_set;
8098	1158	100	100			3266	$interface->{hardware}->{no_nat_set} = $no_nat_set
8099							if $router->{managed} \|\| $router->{routing_only};
8100							}
8101							}
8102							}
8103	332					644	return();
8104							}
8105
8106							# Real interface of crypto tunnel has got {no_nat_set} of that NAT domain,
8107							# where encrypted traffic passes. But real interface gets ACL that filter
8108							# both encrypted and unencrypted traffic. Hence no_nat_set must be extended by
8109							# no_nat_set of some corresponding tunnel interface.
8110							sub adjust_crypto_nat {
8111	332			332	0	296	my %seen;
8112	332					525	for my $crypto (values %crypto) {
8113	21 21					18 29	for my $tunnel (@{ $crypto->{tunnels} }) {
8114	25	50				40	next if $tunnel->{disabled};
8115	25 25					21 31	for my $tunnel_intf (@{ $tunnel->{interfaces} }) {
8116	50					43	my $real_intf = $tunnel_intf->{real_interface};
8117	50	100				117	next if $seen{$real_intf}++;
8118	43	100				79	$real_intf->{router}->{managed} or next;
8119	21					23	my $tunnel_set = $tunnel_intf->{no_nat_set};
8120	21	100				63	keys %$tunnel_set or next;
8121
8122							# Copy hash, because it is shared with other interfaces.
8123	3					4	my $real_set = $real_intf->{no_nat_set};
8124	3					4	$real_set = $real_intf->{no_nat_set} = { %$real_set };
8125	3					3	my $hardware = $real_intf->{hardware};
8126	3	50				7	$hardware->{no_nat_set} = $real_set if ref $hardware;
8127	3					7	for my $nat_tag (sort keys %$tunnel_set) {
8128							# debug "Adjust NAT of $real_intf->{name}: $nat_tag";
8129	3					12	$real_set->{$nat_tag} = 1;
8130							}
8131							}
8132							}
8133							}
8134	332					392	return;
8135							}
8136
8137							sub get_nat_network {
8138	6083			6083	0	5084	my ($network, $no_nat_set) = @_;
8139	6083	100	67			11050	if (my $href = $network->{nat} and $no_nat_set) {
8140	582					920	for my $tag (keys %$href) {
8141	622	100				1178	next if $no_nat_set->{$tag};
8142	299					528	return $href->{$tag};
8143							}
8144							}
8145	5784					6405	return $network;
8146							}
8147
8148							####################################################################
8149							# Find sub-networks
8150							# Mark each network with the smallest network enclosing it.
8151							####################################################################
8152
8153							# All interfaces and hosts of a network must be located in that part
8154							# of the network which doesn't overlap with some subnet.
8155							sub check_subnets {
8156	516			516	0	451	my ($network, $subnet) = @_;
8157	516	100	100			1303	return if $network->{is_aggregate} \|\| $subnet->{is_aggregate};
8158	180 180					149 261	my ($sub_ip, $sub_mask) = @{$subnet}{qw(ip mask)};
8159							my $check = sub {
8160	150			150		157	my ($ip1, $ip2, $object) = @_;
8161	150	0	20			180	if (
8162							match_ip($ip1, $sub_ip, $sub_mask)
8163							\|\| $ip2 && (match_ip($ip2, $sub_ip, $sub_mask)
8164							\|\| ($ip1 <= $sub_ip && $sub_ip <= $ip2))
8165							)
8166							{
8167
8168							# NAT to an interface address (masquerading) is allowed.
8169	0	0	0			0	if ( (my $nat_tags = $object->{bind_nat})
8170							and (my ($nat_tag2) = ($subnet->{name} =~ /^nat:(.*)\(/)))
8171							{
8172	0 0	0	0			0 0	if ( grep { $_ eq $nat_tag2 } @$nat_tags
8173							and $object->{ip} == $subnet->{ip}
8174							and $subnet->{mask} == 0xffffffff)
8175							{
8176	0					0	return;
8177							}
8178							}
8179	0					0	warn_msg("$object->{name}'s IP overlaps with subnet",
8180							" $subnet->{name}");
8181							}
8182	180					588	};
8183	180 180					166 241	for my $interface (@{ $network->{interfaces} }) {
8184	350					326	my $ip = $interface->{ip};
8185	350	100				889	next if $ip =~ /^(?:unnumbered\|negotiated\|tunnel\|short\|bridged)$/;
8186	145					185	$check->($ip, undef, $interface);
8187							}
8188	180 180					179 248	for my $host (@{ $network->{hosts} }) {
8189	5	50 0				15	if (my $ip = $host->{ip}) {
8190	5					7	$check->($ip, undef, $host);
8191							}
8192							elsif (my $range = $host->{range}) {
8193	0					0	$check->($range->[0], $range->[1], $host);
8194							}
8195							}
8196	180					836	return;
8197							}
8198
8199							# Dynamic NAT to loopback interface is OK,
8200							# if NAT is applied at device of loopback interface.
8201							sub nat_to_loopback_ok {
8202	3			3	0	3	my ($loopback_network, $nat_network) = @_;
8203
8204	3					4	my $nat_tag1 = $nat_network->{dynamic};
8205	3					4	my $device_count = 0;
8206	3					3	my $all_device_ok = 0;
8207
8208							# In case of virtual loopback, the loopback network
8209							# is attached to two or more routers.
8210							# Loop over these devices.
8211	3 3					4 4	for my $loop_intf (@{ $loopback_network->{interfaces} }) {
8212	5					5	$device_count++;
8213	5					4	my $this_device_ok = 0;
8214
8215							# Check all interfaces of attached device.
8216	5 5					4 9	for my $all_intf (@{ $loop_intf->{router}->{interfaces} }) {
8217	5	50				9	if (my $nat_tags = $all_intf->{bind_nat}) {
8218	5 5	50				6 11	if (grep { $_ eq $nat_tag1 } @$nat_tags) {
8219	5					4	$this_device_ok = 1;
8220	5					6	last;
8221							}
8222							}
8223							}
8224	5					8	$all_device_ok += $this_device_ok;
8225							}
8226	3					8	return ($all_device_ok == $device_count);
8227							}
8228
8229	1272			1272	0	2008	sub numerically { return $a <=> $b }
8230	1812			1812	0	2947	sub by_name { return $a->{name} cmp $b->{name} }
8231
8232							sub link_reroute_permit;
8233
8234							# Find subnet relation between networks inside a zone.
8235							# - $subnet->{up} = $bignet;
8236							sub find_subnets_in_zone {
8237	332			332	0	457	progress('Finding subnets in zone');
8238	332					350	for my $zone (@zones) {
8239
8240							# Check NAT inside zone.
8241							# Find networks of zone which use a NATed address inside the zone.
8242							# - Use this NATed address in subnet checks.
8243							# - If a subnet relation exists, then this NAT must be unique inside
8244							# the zone.
8245
8246	882					953	my $first_intf = $zone->{interfaces}->[0];
8247	882					706	my %seen;
8248
8249							# Collect NAT tags, that are defined and applied inside the zone.
8250							my %net2zone_nat_tags;
8251
8252							# Handle different no_nat_sets visible at border of zone.
8253							# For a zone without NAT, this loop is executed only once.
8254	882 882					672 1032	for my $interface (@{ $zone->{interfaces} }) {
8255	1158					1036	my $no_nat_set = $interface->{no_nat_set};
8256							# debug $interface->{name};
8257	1158	100				2784	next if $seen{$no_nat_set}++;
8258
8259							# Add networks of zone to %mask_ip_hash.
8260							# Use NAT IP/mask.
8261	865					635	my %mask_ip_hash;
8262
8263	865 865 865					642 892 1088	for my $network (@{ $zone->{networks} },
8264							values %{ $zone->{ipmask2aggregate} })
8265							{
8266	1107	50				2520	next if $network->{ip} =~ /^(?:unnumbered\|tunnel)$/;
8267
8268
8269	1107					915	my $nat_network = $network;
8270	1107	100				1635	if (my $href = $network->{nat}) {
8271	113					182	for my $tag (keys %$href) {
8272	129	100				293	next if $no_nat_set->{$tag};
8273	16 16					15 49	push @{ $net2zone_nat_tags{$network} }, $tag;
8274	16					23	$nat_network = $href->{$tag};
8275	16					17	last;
8276							}
8277							}
8278
8279	1107	100				1586	if ($nat_network->{hidden}) {
8280	6	100				16	my $other = $network->{up} or next;
8281	1	50				2	next if get_nat_network($other, $no_nat_set)->{hidden};
8282	1					9	err_msg("Ambiguous subnet relation from NAT.\n",
8283							" $network->{name} is subnet of\n",
8284							" - $other->{name} at",
8285							" $first_intf->{name}\n",
8286							" - but it is hidden $nat_network->{name} at",
8287							" $interface->{name}");
8288	1					3	next;
8289							}
8290	1101 1101					842 1639	my ($ip, $mask) = @{$nat_network}{ 'ip', 'mask' };
8291
8292							# Found two different networks with identical IP/mask.
8293	1101	100				2297	if (my $other_net = $mask_ip_hash{$mask}->{$ip}) {
8294	1					2	my $name1 = $network->{name};
8295	1					2	my $name2 = $other_net->{name};
8296	1					5	err_msg("$name1 and $name2 have identical IP/mask",
8297							" at $interface->{name}");
8298							}
8299							else {
8300
8301							# Store original network under NAT IP/mask.
8302	1100					2515	$mask_ip_hash{$mask}->{$ip} = $network;
8303							}
8304							}
8305
8306							# Compare networks of zone.
8307							# Go from smaller to larger networks.
8308	865					2215	my @mask_list = reverse sort numerically keys %mask_ip_hash;
8309	865					1622	while (my $mask = shift @mask_list) {
8310
8311							# No supernets available
8312	942	100				2916	last if not @mask_list;
8313
8314	130					140	my $ip_hash = $mask_ip_hash{$mask};
8315							SUBNET:
8316	130					320	for my $ip (sort numerically keys %$ip_hash) {
8317
8318	160					161	my $subnet = $ip_hash->{$ip};
8319
8320							# Find networks which include current subnet.
8321							# @mask_list holds masks of potential supernets.
8322	160					175	for my $m (@mask_list) {
8323
8324	181					209	my $i = $ip & $m;
8325	181	100				420	my $bignet = $mask_ip_hash{$m}->{$i} or next;
8326
8327							# Collect subnet relation for first no_nat_set.
8328	111	100				227	if ($interface eq $first_intf) {
8329	105					128	$subnet->{up} = $bignet;
8330							# debug "$subnet->{name} -up-> $bignet->{name}";
8331
8332	105					235	push(
8333	17	50				36	@{ $bignet->{networks} },
8334							$subnet->{is_aggregate}
8335	105	100				90	? @{ $subnet->{networks} \|\| [] }
8336							: ($subnet)
8337							);
8338
8339	105					168	check_subnets($bignet, $subnet);
8340							}
8341
8342							# Check for ambiguous subnet relation with
8343							# other no_nat_sets.
8344	6	100				10	else {if (my $other = $subnet->{up}) {
8345	5	100				12	if ($other ne $bignet) {
8346	1					8	err_msg(
8347							"Ambiguous subnet relation from NAT.\n",
8348							" $subnet->{name} is subnet of\n",
8349							" - $other->{name} at",
8350							" $first_intf->{name}\n",
8351							" - $bignet->{name} at",
8352							" $interface->{name}");
8353							}
8354							}
8355							else {
8356	1					7	err_msg(
8357							"Ambiguous subnet relation from NAT.\n",
8358							" $subnet->{name} is subnet of\n",
8359							" - $bignet->{name} at",
8360							" $interface->{name}\n",
8361							" - but has no subnet relation at",
8362							" $first_intf->{name}");
8363							}
8364							}
8365
8366							# We only need to find the smallest enclosing
8367							# network.
8368	111					482	next SUBNET;
8369							}
8370	49	100				174	if ($interface ne $first_intf) {
8371	3	50				6	if (my $other = $subnet->{up}) {
8372	3					16	err_msg("Ambiguous subnet relation from NAT.\n",
8373							" $subnet->{name} is subnet of\n",
8374							" - $other->{name} at",
8375							" $first_intf->{name}\n",
8376							" - but has no subnet relation at",
8377							" $interface->{name}");
8378							}
8379							}
8380							}
8381							}
8382							}
8383
8384							# For each subnet N find the largest non-aggregate network
8385							# which encloses N. If one exists, store it in %max_up_net.
8386							# This is used to exclude subnets from $zone->{networks} below.
8387							# It is also used to derive attribute {max_routing_net}.
8388	882					812	my %max_up_net;
8389							my $set_max_net;
8390							$set_max_net = sub {
8391	2254			2254		2511	my ($network) = @_;
8392	2254	100				4032	return if not $network;
8393	1182	100				2152	if (my $max_net = $max_up_net{$network}) {
8394	4					6	return $max_net;
8395							}
8396	1178	100				3020	if (my $max_net = $set_max_net->($network->{up})) {
8397	66	100				113	if (!$network->{is_aggregate}) {
8398	56					110	$max_up_net{$network} = $max_net;
8399
8400							# debug("$network->{name} max_up $max_net->{name}");
8401							}
8402	66					130	return $max_net;
8403							}
8404	1112	100				2009	if ($network->{is_aggregate}) {
8405	40					74	return;
8406							}
8407	1072					1829	return $network;
8408	882					2493	};
8409	882 882					758 1912	$set_max_net->($_) for @{ $zone->{networks} };
8410
8411							# For each subnet N find the largest non-aggregate network
8412							# which encloses N and which has the same NAT settings as N.
8413							# If one exists, store it in {max_routing_net}. This is used
8414							# for generating static routes.
8415	882 882					771 1165	for my $network (@{ $zone->{networks} }) {
8416	1076	100				2540	my $max = $max_up_net{$network} or next;
8417							# debug "Check $network->{name} $max->{name}";
8418
8419							my $get_zone_nat = sub {
8420	130			130		119	my ($network) = @_;
8421	130		100			337	my $nat = $network->{nat} \|\| {};
8422
8423							# Special case:
8424							# NAT is applied to $network inside the zone.
8425							# Ignore NAT tag when comparing with NAT of $up.
8426	130	100				242	if (my $aref = $net2zone_nat_tags{$network}) {
8427	8					18	$nat = { %$nat };
8428	8					12	for my $nat_tag (@$aref) {
8429	8					17	delete $nat->{$nat_tag};
8430							}
8431							}
8432	130					162	return $nat;
8433	56					169	};
8434	56					81	my $nat = $get_zone_nat->($network);
8435	56					52	my $max_routing;
8436	56					61	my $up = $network->{up};
8437							UP:
8438	56					93	while ($up) {
8439
8440							# Check if NAT settings are identical.
8441	74					85	my $up_nat = $get_zone_nat->($up);
8442	74	100				161	keys %$nat == keys %$up_nat or last UP;
8443	67					124	for my $tag (keys %$nat) {
8444	3	50				6	my $up_nat_info = $up_nat->{$tag} or last UP;
8445	3					3	my $nat_info = $nat->{$tag};
8446	3	50				5	if ($nat_info->{hidden}) {
8447	0	0				0	$up_nat_info->{hidden} or last UP;
8448							}
8449							else {
8450
8451							# Check if subnet relation is maintained
8452							# for NAT addresses.
8453	3	50				5	$up_nat_info->{hidden} and last UP;
8454	3 3					2 4	my($ip, $mask) = @{$nat_info}{qw(ip mask)};
8455	3	100				7	match_ip($up_nat_info->{ip}, $ip, $mask) or last UP;
8456	1	50				4	$up_nat_info->{mask} >= $mask or last UP;
8457							}
8458							}
8459	65	100				118	if (!$up->{is_aggregate}) {
8460	50					53	$max_routing = $up;
8461							}
8462	65					135	$up = $up->{up};
8463							}
8464	56	100				109	if ($max_routing) {
8465	49					202	$network->{max_routing_net} = $max_routing;
8466							# debug "Found $max_routing->{name}";
8467							}
8468							}
8469
8470							# Remove subnets of non-aggregate networks.
8471	1076					2438	$zone->{networks} =
8472	882 882					800 1039	[ grep { !$max_up_net{$_} } @{ $zone->{networks} } ];
8473
8474							# Propagate managed hosts to aggregates.
8475	882 882					953 2524	for my $aggregate (values %{ $zone->{ipmask2aggregate} }) {
8476	53					105	add_managed_hosts_to_aggregate($aggregate);
8477							}
8478							}
8479
8480							# It is valid to have an aggregate in a zone which has no matching
8481							# networks. This can be useful to add optimization rules at an
8482							# intermediate device.
8483
8484							# Change NAT at interface after above checks.
8485	332					517	adjust_crypto_nat();
8486
8487							# Call late after $zone->{networks} has been set up.
8488	332					449	link_reroute_permit();
8489	332					429	check_managed_local();
8490	332					278	return;
8491							}
8492
8493							# Find subnet relation inside a NAT domain.
8494							# - $subnet->{is_in}->{$no_nat_set} = $bignet;
8495							# - $net1->{is_identical}->{$no_nat_set} = $net2
8496							#
8497							# Mark networks, having subnet in other zone: $bignet->{has_other_subnet}
8498							# If set, this prevents secondary optimization.
8499							sub find_subnets_in_nat_domain {
8500	326			326	0	311	my $count = @natdomains;
8501	326					761	progress("Finding subnets in $count NAT domains");
8502	326					310	my %seen;
8503
8504	326					375	for my $domain (@natdomains) {
8505	437					438	my $no_nat_set = $domain->{no_nat_set};
8506
8507							# debug("$domain->{name} ", join ',', sort keys %$no_nat_set);
8508	437					375	my %mask_ip_hash;
8509							my %identical;
8510	437					442	for my $network (@networks) {
8511	1768	100				3520	next if $network->{ip} =~ /^(?:unnumbered\|tunnel)$/;
8512	1698					1940	my $nat_network = get_nat_network($network, $no_nat_set);
8513	1698	100				2460	next if $nat_network->{hidden};
8514	1663 1663					1279 2095	my ($ip, $mask) = @{$nat_network}{ 'ip', 'mask' };
8515
8516							# Found two different networks with identical IP/mask.
8517							# in current NAT domain.
8518	1663	100				2992	if (my $old_net = $mask_ip_hash{$mask}->{$ip}) {
8519	57					71	my $nat_old_net = get_nat_network($old_net, $no_nat_set);
8520	57					59	my $error;
8521	57	100 100 100 50 50	50 67 67 67 33 50			238	if ($old_net->{is_aggregate} \|\| $network->{is_aggregate}) {
8522	41	50				92	if ($old_net->{zone} eq $network->{zone}) {
8523	0					0	$error = 1;
8524							}
8525							else {
8526	41	50 50				111	if (!$old_net->{is_aggregate}) {
8527
8528							# This network has aggregate (with
8529							# subnets) in other zone. Hence this
8530							# network must not be used in secondary
8531							# optimization.
8532	0					0	$old_net->{has_other_subnet} = 1;
8533							}
8534							elsif (!$network->{is_aggregate}) {
8535	0					0	$network->{has_other_subnet} = 1;
8536							}
8537							}
8538							}
8539							elsif ($nat_old_net->{dynamic} and $nat_network->{dynamic}) {
8540
8541							# Dynamic NAT of different networks
8542							# to a single new IP/mask is OK.
8543							}
8544							elsif ($old_net->{loopback} and $nat_network->{dynamic}) {
8545	3	50				7	nat_to_loopback_ok($old_net, $nat_network) or $error = 1;
8546							}
8547							elsif ($nat_old_net->{dynamic} and $network->{loopback}) {
8548	0	0				0	nat_to_loopback_ok($network, $nat_old_net) or $error = 1;
8549							}
8550							elsif (($network->{bridged} \|\| 0) eq ($old_net->{bridged} \|\| 1))
8551							{
8552
8553							# Parts of bridged network have identical IP by design.
8554							}
8555							else {
8556	0					0	$error = 1;
8557							}
8558	57	50				94	if ($error) {
8559	0					0	my $name1 = $nat_network->{name};
8560	0					0	my $name2 = $nat_old_net->{name};
8561	0					0	err_msg("$name1 and $name2 have identical IP/mask\n",
8562							" in $domain->{name}");
8563							}
8564							else {
8565
8566							# Remember identical networks.
8567	57		100			202	$identical{$old_net} \|\|= [$old_net];
8568	57 57					53 156	push @{ $identical{$old_net} }, $network;
8569							}
8570							}
8571							else {
8572
8573							# Store original network under NAT IP/mask.
8574	1606					2967	$mask_ip_hash{$mask}->{$ip} = $network;
8575							}
8576							}
8577
8578							# Link identical networks to one representative one.
8579	437					780	for my $networks (values %identical) {
8580	41					127	$_->{is_supernet} = 1 for @$networks;
8581	41					59	my $one_net = shift(@$networks);
8582	41					50	for my $network (@$networks) {
8583	57					171	$network->{is_identical}->{$no_nat_set} = $one_net;
8584							# debug("Identical: $network->{name}: $one_net->{name}");
8585							}
8586							}
8587
8588							# Go from smaller to larger networks.
8589	437					1163	my @mask_list = reverse sort numerically keys %mask_ip_hash;
8590	437					1230	while (my $mask = shift @mask_list) {
8591
8592							# No supernets available
8593	713	100				1931	last if not @mask_list;
8594
8595	373					380	my $ip_hash = $mask_ip_hash{$mask};
8596	373					1261	for my $ip (sort numerically keys %$ip_hash) {
8597
8598							# It is sufficient to set subset relation for only one
8599							# network out of multiple identical networks.
8600							# In all contexts where {is_in} is used,
8601							# we apply {is_identical} to the network before.
8602	703					654	my $subnet = $ip_hash->{$ip};
8603
8604							# Find networks which include current subnet.
8605							# @mask_list holds masks of potential supernets.
8606	703					666	for my $m (@mask_list) {
8607	905					820	my $i = $ip & $m;
8608	905	100				2071	my $bignet = $mask_ip_hash{$m}->{$i} or next;
8609	527					608	my $nat_subnet = get_nat_network($subnet, $no_nat_set);
8610	527					623	my $nat_bignet = get_nat_network($bignet, $no_nat_set);
8611
8612							# Mark subnet relation.
8613							# This may differ for different NAT domains.
8614	527					950	$subnet->{is_in}->{$no_nat_set} = $bignet;
8615							# debug "$subnet->{name} -is_in-> $bignet->{name}";
8616
8617	527	100				1009	if ($bignet->{zone} eq $subnet->{zone}) {
8618	222	100				356	if ($subnet->{has_other_subnet}) {
8619							# debug "has other1: $bignet->{name}";
8620	6					9	$bignet->{has_other_subnet} = 1;
8621							}
8622							}
8623							else {
8624							# debug "has other: $bignet->{name}";
8625	305					334	$bignet->{has_other_subnet} = 1;
8626							}
8627
8628							# Mark network having subnets. Rules having
8629							# src or dst with subnets are collected into
8630							# $expanded_rules->{supernet}
8631	527					504	$bignet->{is_supernet} = 1;
8632
8633	527	100				1161	if ($seen{$nat_bignet}->{$nat_subnet}) {
8634	116					283	last;
8635							}
8636	411					658	$seen{$nat_bignet}->{$nat_subnet} = 1;
8637
8638	411	50				643	if ($config{check_subnets}) {
8639
8640							# Take original $bignet, because currently
8641							# there's no method to specify a natted network
8642							# as value of subnet_of.
8643	411	100	62			1362	if (
8644							not( $bignet->{is_aggregate}
8645							or $subnet->{is_aggregate}
8646							or $bignet->{has_subnets}
8647							or $nat_subnet->{subnet_of}
8648							and $nat_subnet->{subnet_of} eq $bignet
8649							or $nat_subnet->{is_layer3})
8650							)
8651							{
8652
8653							# Prevent multiple error messages in
8654							# different NAT domains.
8655	2		33			8	$nat_subnet->{subnet_of} \|\|= $bignet;
8656
8657	2					14	my $msg =
8658							"$nat_subnet->{name} is subnet of"
8659							. " $nat_bignet->{name}\n"
8660							. " in $domain->{name}.\n"
8661							. " If desired, either declare attribute"
8662							. " 'subnet_of' or attribute 'has_subnets'";
8663
8664	2	50				6	if ($config{check_subnets} eq 'warn') {
8665	2					4	warn_msg($msg);
8666							}
8667							else {
8668	0					0	err_msg($msg);
8669							}
8670							}
8671							}
8672
8673	411					491	check_subnets($nat_bignet, $nat_subnet);
8674	411					1316	last;
8675							}
8676							}
8677							}
8678							}
8679
8680							# Secondary optimization substitutes a host or interface by its
8681							# largest valid supernet inside the same security zone. This
8682							# supernet has already been calculated and stored in
8683							# {max_routing_net}. But {max_routing_net} can't be used if it has
8684							# a subnet in some other security zone. In this case we have to
8685							# search again for a supernet without attribute {has_other_subnet}.
8686							# The result is stored in {max_secondary_net}.
8687	326					430	for my $network (@networks) {
8688	1239	100				2114	my $max = $network->{max_routing_net} or next;
8689	49	100				92	if(!$max->{has_other_subnet}) {
8690	22					37	$network->{max_secondary_net} = $max;
8691	22					26	next;
8692							}
8693	27					28	my $max_secondary;
8694	27					30	my $up = $network->{up};
8695	27					43	while ($up) {
8696	29	100				45	if ($up->{has_other_subnet}) {
8697	27					20	last;
8698							}
8699							else {
8700	2	100				4	if (!$up->{is_aggregate}) {
8701	1					1	$max_secondary = $up;
8702							}
8703	2					3	$up = $up->{up};
8704							}
8705							}
8706	27	100				51	$network->{max_secondary_net} = $max_secondary if $max_secondary;
8707							}
8708	326					490	return;
8709							}
8710
8711							#############################################################################
8712							# Purpose : Moves attribute 'no_in_acl' from interfaces to hardware because
8713							# ACLs operate on hardware, not on logic. Marks hardware needing
8714							# outgoing ACLs.
8715							# Comments : Not more than 1 'no_in_acl' interface/router allowed.
8716							sub check_no_in_acl {
8717
8718							# Process every managed router
8719	337			337	0	393	for my $router (@managed_routers) {
8720	485					394	my $counter = 0; # count 'no_in_acl' interfaces/router
8721
8722							# At interfaces with no_in_acl move attribute to hardware
8723	485 485					399 603	for my $interface (@{ $router->{interfaces} }) {
8724	1112	100				1949	if (delete $interface->{no_in_acl}) {
8725	7					13	my $hardware = $interface->{hardware};
8726	7					13	$hardware->{no_in_acl} = 1;
8727
8728							# Assure max number of main interfaces at no_in_acl-hardware =1
8729	7					25	1 ==
8730							grep(
8731	7 7	50				9 13	{ not $_->{main_interface} } @{ $hardware->{interfaces} })
8732							or err_msg
8733							"Only one logical interface allowed at $hardware->{name}",
8734							" because it has attribute 'no_in_acl'";
8735	7					7	$counter++;
8736
8737							# Reference no_in_acl interface in router attribute
8738	7					12	$router->{no_in_acl} = $interface;
8739							}
8740							}
8741	485	100				965	next if not $counter;
8742
8743							# Assert maximum number of 'no_in_acl' interfaces per router
8744	7	50				15	$counter == 1
8745							or err_msg "At most one interface of $router->{name}",
8746							" may use flag 'no_in_acl'";
8747
8748							# Assert router to support outgoing ACL
8749	7	50				17	$router->{model}->{has_out_acl}
8750							or err_msg("$router->{name} doesn't support outgoing ACL");
8751
8752							# Assert router not to take part in crypto tunnels
8753	7 23 7	50 50				12 84 10	if (grep { $_->{hub} or $_->{spoke} } @{ $router->{interfaces} }) {
8754	0					0	err_msg "Don't use attribute 'no_in_acl' together",
8755							" with crypto tunnel at $router->{name}";
8756							}
8757
8758							# Mark other hardware with attribute 'need_out_acl'.
8759	7 7					10 11	for my $hardware (@{ $router->{hardware} }) {
8760	22	100				48	$hardware->{no_in_acl}
8761							or $hardware->{need_out_acl} = 1;
8762							}
8763							}
8764	337					319	return;
8765							}
8766
8767							# If routers are connected by crosslink network then
8768							# no filter is needed if both have equal strength.
8769							# If routers have different strength,
8770							# then only the weakest devices omit the filter.
8771							my %crosslink_strength = (
8772							primary => 10,
8773							full => 10,
8774							standard => 9,
8775							secondary => 8,
8776							local => 7,
8777							local_secondary => 6,
8778							);
8779							##############################################################################
8780							# Find clusters of routers connected directly or indirectly by
8781							# crosslink networks and having at least one device with
8782							# "need_protect".
8783							sub cluster_crosslink_routers {
8784	337			337	0	345	my ($crosslink_routers) = @_;
8785	337					287	my %cluster;
8786							my %seen;
8787	0					0	my $walk;
8788
8789							# add routers to cluster via depth first search
8790							$walk = sub {
8791	17			17		15	my ($router) = @_;
8792	17					24	$cluster{$router} = $router;
8793	17					25	$seen{$router} = $router;
8794	17 17					12 20	for my $in_intf (@{ $router->{interfaces} }) {
8795	36					34	my $network = $in_intf->{network};
8796	36	100				63	next if not $network->{crosslink};
8797	18	50				24	next if $network->{disabled};
8798	18 18					15 20	for my $out_intf (@{ $network->{interfaces} }) {
8799	42	100				81	next if $out_intf eq $in_intf;
8800	24					24	my $router2 = $out_intf->{router};
8801	24	100				60	next if $cluster{$router2};
8802	9					21	$walk->($router2);
8803							}
8804							}
8805	337					1099	};
8806
8807							# Process all need_protect crosslinked routers
8808	337					725	for my $router (values %$crosslink_routers) {
8809	10	100				19	next if $seen{$router};
8810
8811							# Fill router cluster
8812	8					9	%cluster = ();
8813	8					12	$walk->($router);
8814
8815							# Collect all interfaces belonging to need_protect routers of cluster...
8816	21					33	my @crosslink_interfaces =
8817	10					15	grep { !$_->{vip} }
8818	10 17					9 27	map { @{ $_->{interfaces} } }
8819	8					27	grep { $crosslink_routers->{$_} }
8820							sort by_name values %cluster; # Sort to make output deterministic.
8821
8822							# ... add information to every cluster member
8823	8 20					9 47	my %crosslink_intf_hash = map { $_ => $_ } @crosslink_interfaces;
8824	8					11	for my $router2 (values %cluster) {
8825							# ... as list used in "protect own interfaces"
8826	17					20	$router2->{crosslink_interfaces} = \@crosslink_interfaces;
8827							# ... as hash used in fast lookup in distribute_rule and "protect.."
8828	17					31	$router2->{crosslink_intf_hash} = \%crosslink_intf_hash;
8829							}
8830							}
8831	337					466	return;
8832							}
8833							##############################################################################
8834							# A crosslink network combines two or more routers to one virtual router.
8835							# Purpose : Assures proper usage of crosslink networks and applies the
8836							# crosslink attribute to the networks weakest interfaces (no
8837							# filtering needed at these interfaces).
8838							# Comments : Function uses hardware attributes from sub check_no_in_acl.
8839							sub check_crosslink {
8840	337			337	0	290	my %crosslink_routers; # Collect crosslinked routers with {need_protect}
8841
8842							# Process all crosslink networks
8843	337					528	for my $network (values %networks) {
8844	1115	100				1888	next if not $network->{crosslink};
8845	10	50				19	next if $network->{disabled};
8846
8847							# Prepare tests.
8848	10					7	my %strength2intf;# To identify interfaces with min router strength
8849	10					8	my $out_acl_count = 0; # Assure out_ACL at all/none of the interfaces
8850	10					10	my @no_in_acl_intf; # Assure all no_in_acl IFs to border the same zone
8851
8852							# Process network interfaces to fill above variables.
8853	10 10					6 16	for my $interface (@{ $network->{interfaces} }) {
8854	19	100				28	next if $interface->{main_interface};
8855	18					18	my $router = $interface->{router};
8856	18					17	my $hardware = $interface->{hardware};
8857
8858							# Assure correct usage of crosslink network.
8859	18	100				25	if (!$router->{managed}) {
8860	1					4	err_msg("Crosslink $network->{name} must not be",
8861							" connected to unmanged $router->{name}");
8862	1					2	next;
8863							}
8864	17 18 17	50				17 44 20	1 == grep({ !$_->{main_interface} } @{ $hardware->{interfaces} })
8865							or err_msg
8866							"Crosslink $network->{name} must be the only network\n",
8867							" connected to $hardware->{name} of $router->{name}";
8868
8869							# Fill variables.
8870	17					18	my $managed = $router->{managed};
8871	17	50				29	my $strength = $crosslink_strength{$managed} or
8872							internal_err("Unexptected managed=$managed");
8873	17 17					13 34	push @{ $strength2intf{$strength} }, $interface;
8874
8875	17	100				29	if ($router->{need_protect}) {
8876	10					18	$crosslink_routers{$router} = $router;
8877							}
8878
8879	17	50				26	if ($hardware->{need_out_acl}) {
8880	0					0	$out_acl_count++;
8881							}
8882
8883	36					49	push @no_in_acl_intf,
8884	17 17					12 18	grep({ $_->{hardware}->{no_in_acl} } @{ $router->{interfaces} });
8885							}
8886
8887							# Apply attribute {crosslink} to the networks weakest interfaces.
8888	10	100				32	if (my ($weakest) = sort numerically keys %strength2intf) {
8889	8 8					7 11	for my $interface (@{ $strength2intf{$weakest} }) {
8890	13					21	$interface->{hardware}->{crosslink} = 1;
8891							}
8892
8893							# Assure 'secondary' and 'local' are not mixed in crosslink network.
8894	8	100	100			25	if ($weakest == $crosslink_strength{local} &&
8895							$strength2intf{$crosslink_strength{secondary}}) {
8896	1					4	err_msg("Must not use 'managed=local' and 'managed=secondary'",
8897							" together\n at crosslink $network->{name}");
8898							}
8899							}
8900
8901							# Assure proper usage of crosslink network.
8902	0					0	not $out_acl_count
8903	10	50	33			23	or $out_acl_count == @{ $network->{interfaces} }
8904							or err_msg "All interfaces must equally use or not use outgoing ACLs",
8905							" at crosslink $network->{name}";
8906	10 0	50				18 0	equal(map { $_->{zone} } @no_in_acl_intf)
8907							or err_msg "All interfaces with attribute 'no_in_acl'",
8908							" at routers connected by\n crosslink $network->{name}",
8909							" must be border of the same security zone";
8910							}
8911	337					492	return \%crosslink_routers;
8912							}
8913
8914							# Find cluster of zones connected by 'local' or 'local_secondary' routers.
8915							# - Check consistency of attributes.
8916							# - Set unique 'local_mark' for all zones belonging to one cluster
8917							# - Set 'local_secondary_mark' for secondary optimization inside one cluster.
8918							# Two zones get the same mark if they are connected by local_secondary router.
8919							sub check_managed_local {
8920	332			332	0	259	my %seen;
8921	332					309	my $cluster_counter = 1;
8922	332					357	for my $router (@managed_routers) {
8923	485	100				1144	$router->{managed} =~ /^local/ or next;
8924	27	100				60	next if $seen{$router};
8925
8926							# Networks of current cluster matching {filter_only}.
8927	20					14	my %matched;
8928
8929							my $walk;
8930							$walk = sub {
8931	27			27		29	my ($router) = @_;
8932	27					28	my $filter_only = $router->{filter_only};
8933	27					19	my $k;
8934	27					45	$seen{$router} = $router;
8935	27 27					22 33	for my $in_intf (@{ $router->{interfaces} }) {
8936	54					48	my $no_nat_set = $in_intf->{no_nat_set};
8937	54					44	my $zone0 = $in_intf->{zone};
8938	54					42	my $zone_cluster = $zone0->{zone_cluster};
8939	54	50				77	for my $zone ($zone_cluster ? @$zone_cluster : ($zone0)) {
8940	54	50				79	next if $zone->{disabled};
8941	54	100				91	next if $zone->{local_mark};
8942	44					44	$zone->{local_mark} = $cluster_counter;
8943
8944							# All networks in local zone must match {filter_only}.
8945	44					44	NETWORK:
8946	44 44					33 56	for my $network (@{ $zone->{networks} },
8947							values %{ $zone->{ipmask2aggregate} })
8948							{
8949	46 46					31 58	my ($ip, $mask) = @{ address($network, $no_nat_set) };
8950
8951							# Ignore aggregate 0/0 which is available in
8952							# every zone.
8953	46	100	67			100	next if $mask == 0 && $network->{is_aggregate};
8954	45					51	for my $pair (@$filter_only) {
8955	50					56	my ($i, $m) = @$pair;
8956	50	100	100			103	if ($mask >= $m && match_ip($ip, $i, $m)) {
8957	42					98	$matched{"$i/$m"} = 1;
8958	42					90	next NETWORK;
8959							}
8960							}
8961	3					12	err_msg("$network->{name} doesn't match attribute",
8962							" 'filter_only' of $router->{name}");
8963							}
8964	44 44					38 57	for my $out_intf (@{ $zone->{interfaces} }) {
8965	66	100				207	next if $out_intf eq $in_intf;
8966	22					22	my $router2 = $out_intf->{router};
8967	22	50				38	my $managed = $router2->{managed} or next;
8968	22	100				62	next if $managed !~ /^local/;
8969	10	100				23	next if $seen{$router2};
8970
8971							# All routers of a cluster must have same values in
8972							# {filter_only}.
8973	7 7		67			17 26	$k \|\|= join(',', map({ join('/', @$_) }
8974							@$filter_only));
8975	8 7					22 15	my $k2 = join(',', map({ join('/', @$_) }
8976	7					11	@{ $router2->{filter_only} }));
8977	7	100				18	$k2 eq $k or
8978							err_msg("$router->{name} and $router2->{name}",
8979							" must have identical values in",
8980							" attribute 'filter_only'");
8981
8982	7					23	$walk->($router2);
8983							}
8984							}
8985							}
8986	20					96	};
8987
8988	20					32	$walk->($router);
8989	20					15	$cluster_counter++;
8990
8991	20 20					17 27	for my $pair (@{ $router->{filter_only} }) {
8992	25					25	my ($i, $m) = @$pair;
8993	25	100				82	$matched{"$i/$m"} and next;
8994	1					2	my $ip = print_ip($i);
8995	1					2	my $prefix = mask2prefix($m);
8996	1					5	warn_msg("Useless $ip/$prefix in attribute 'filter_only'",
8997							" of $router->{name}");
8998							}
8999							}
9000	332					391	return;
9001							}
9002
9003							# group of reroute_permit networks must be expanded late, after areas,
9004							# aggregates and subnets have been set up. Otherwise automatic groups
9005							# wouldn't work.
9006							#
9007							# Reroute permit is not allowed between different security zones.
9008							sub link_reroute_permit {
9009	332			332	0	374	for my $zone (@zones) {
9010	882 882					673 1057	for my $interface (@{ $zone->{interfaces} }) {
9011	1158	100				2432	my $group = $interface->{reroute_permit} or next;
9012	2					6	$group =
9013							expand_group($group, "'reroute_permit' of $interface->{name}");
9014	2					3	my @checked;
9015	2					2	for my $obj (@$group) {
9016	2	50				3	if (is_network($obj)) {
9017	2					2	my $net_zone = $obj->{zone};
9018	2	50				4	if (!zone_eq($net_zone, $zone)) {
9019	0					0	err_msg("Invalid reroute_permit for $obj->{name} ",
9020							"at $interface->{name}:",
9021							" different security zones");
9022							}
9023							else {
9024	2					4	push @checked, $obj;
9025							}
9026							}
9027							else {
9028	0					0	err_msg("$obj->{name} not allowed in attribute",
9029							" 'reroute_permit' of $interface->{name}");
9030							}
9031							}
9032	2					6	$interface->{reroute_permit} = \@checked;
9033							}
9034							}
9035	332					326	return;
9036							}
9037
9038							##############################################################################
9039							# Purpose :
9040							sub add_managed_hosts_to_aggregate {
9041	160			160	0	140	my ($aggregate) = @_;
9042
9043							# Collect managed hosts of sub-networks.
9044	160					160	my $networks = $aggregate->{networks};
9045	160	100				225	if (@$networks) {
9046	127					162	for my $network (@$networks) {
9047	147	100				355	my $managed_hosts = $network->{managed_hosts} or next;
9048	2 2					2 6	push(@{ $aggregate->{managed_hosts} }, @$managed_hosts);
9049							}
9050							}
9051
9052							# Collect matching managed hosts of all networks of zone.
9053							# Ignore sub-networks of aggregate, because they would have been
9054							# found in $networks above.
9055							else {
9056	33 33					42 51	my ($ip, $mask) = @{$aggregate}{qw(ip mask)};
9057	33					33	my $zone = $aggregate->{zone};
9058	33 33					1069 48	for my $network (@{ $zone->{networks} }) {
9059	30	100				76	next if $network->{mask} > $mask ;
9060	10	100				29	my $managed_hosts = $network->{managed_hosts} or next;
9061	1 2					3 4	push(@{ $aggregate->{managed_hosts} },
9062	1					1	grep { match_ip($_->{ip}, $ip, $mask) } @$managed_hosts);
9063							}
9064							}
9065	160					249	return;
9066							}
9067
9068							####################################################################
9069							# Borders of security zones are
9070							# a) interfaces of managed devices and
9071							# b) interfaces of devices, which have at least one pathrestriction applied.
9072							#
9073							# For each security zone create a zone object.
9074							# Link each interface at the border with the zone and vice versa.
9075							# Additionally link each network and unmanaged router with the zone.
9076							# Add a list of all its numbered networks to the zone.
9077							####################################################################
9078
9079							##############################################################################
9080							# Purpose : Link aggregate and zone via references in both objects, set
9081							# aggregate properties according to those of the linked zone.
9082							# Store aggregates in @networks (providing all srcs and dsts).
9083							sub link_aggregate_to_zone {
9084	160			160	0	185	my ($aggregate, $zone, $key) = @_;
9085
9086							# Link aggregate with zone.
9087	160					180	$aggregate->{zone} = $zone;
9088	160					221	$zone->{ipmask2aggregate}->{$key} = $aggregate;
9089
9090							# Take a new array for each aggregate, otherwise we would share
9091							# the same array between different aggregates.
9092	160		100			372	$aggregate->{networks} \|\|= [];# Has to be initialized, even if it is empty
9093
9094							# Set aggregate properties
9095	160	50				256	$zone->{is_tunnel} and $aggregate->{is_tunnel} = 1;
9096	160	100				242	$zone->{has_id_hosts} and $aggregate->{has_id_hosts} = 1;
9097
9098	160	50				224	if ($zone->{disabled}) {
9099	0					0	$aggregate->{disabled} = 1;
9100							}
9101
9102							# Store aggregate reference in global network hash
9103							else {
9104	160					174	push @networks, $aggregate; # @networks provides all srcs/dsts
9105							}
9106	160					222	return;
9107							}
9108
9109							##############################################################################
9110							# Update relations {networks}, {up} and {owner} for implicitly defined
9111							# aggregates.
9112							# Remember:
9113							# {up} is relation inside set of all networks and aggregates.
9114							# {networks} is attribute of aggregates and networks,
9115							# but value is list of networks.
9116							sub link_implicit_aggregate_to_zone {
9117	107			107	0	120	my ($aggregate, $zone, $key) = @_;
9118	107					226	my ($ip, $mask) = split '/', $key;
9119	107					121	my $ipmask2aggregate = $zone->{ipmask2aggregate};
9120
9121							# Collect all aggregates, networks and subnets of current zone.
9122							# Get aggregates in deterministic order.
9123	107 107					145 132	my @objects = @{$ipmask2aggregate}{ sort keys %$ipmask2aggregate };
9124	107					95	my $add_subnets;
9125							$add_subnets = sub {
9126	129			129		127	my ($network) = @_;
9127	129	100				363	my $subnets = $network->{networks} or return;
9128	3					1	push @objects, @$subnets;
9129	3					9	$add_subnets->($_) for @$subnets;
9130	107					298	};
9131	107 107					93 156	push @objects, @{ $zone->{networks} };
9132	107 107					89 218	$add_subnets->($_) for @{ $zone->{networks} };
9133
9134							# Collect all objects being larger and smaller than new aggregate.
9135	107 144					128 287	my @larger = grep { $_->{mask} < $mask } @objects;
9136	107 144					102 233	my @smaller = grep { $_->{mask} > $mask } @objects;
9137
9138							# Find subnets of new aggregate.
9139	107					124	for my $obj (@smaller) {
9140	132 132					105 192	my ($i, $m) = @{$obj}{qw(ip mask)};
9141	132	100				178	match_ip($i, $ip, $mask) or next;
9142
9143							# Ignore sub-subnets, i.e. supernet is smaller than new aggregate.
9144	117	100				205	if (my $up = $obj->{up}) {
9145	15	100				31	next if $up->{mask} >= $mask;
9146							}
9147	105					114	$obj->{up} = $aggregate;
9148							# debug "$obj->{name} -up1-> $aggregate->{name}";
9149	105 9					301 17	push(@{ $aggregate->{networks} },
9150	105	100				92	$obj->{is_aggregate} ? @{ $obj->{networks} } : $obj);
9151							}
9152
9153							# Find supernet of new aggregate.
9154							# Iterate from smaller to larger supernets.
9155							# Stop after smallest supernet has been found.
9156	107 3					190 5	for my $obj (sort { $a->{mask} < $b->{mask} } @larger) {
9157	8 8					9 11	my ($i, $m) = @{$obj}{qw(ip mask)};
9158	8	100				11	match_ip($ip, $i, $m) or next;
9159	7					10	$aggregate->{up} = $obj;
9160							# debug "$aggregate->{name} -up2-> $obj->{name}";
9161	7					8	last;
9162							}
9163
9164							# Inherit owner from smallest supernet having owner or from zone.
9165	107					115	my $up = $aggregate->{up};
9166	107					91	my $owner;
9167	107					190	while ($up) {
9168	7	50				12	$owner = $up->{owner} and last;
9169	7					12	$up = $up->{up};
9170							}
9171	107		67			302	$owner \|\|= $zone->{owner};
9172	107	100				157	$owner and $aggregate->{owner} = $owner;
9173
9174	107					139	link_aggregate_to_zone($aggregate, $zone, $key);
9175	107					138	add_managed_hosts_to_aggregate($aggregate);
9176	107					164	return;
9177							}
9178
9179							##############################################################################
9180							# Purpose : Process all explicitly defined aggregates. Check proper usage of
9181							# aggregates. For every aggregate, link aggregate objects to all
9182							# zones inside the zone cluster containing the aggregates link
9183							# network and set aggregate and zone properties. Add aggregate
9184							# objects to global @networks array.
9185							# Comments : Has to be called after zones have been set up. But before
9186							# find_subnets_in_zone calculates {up} and {networks} relation.
9187							sub link_aggregates {
9188
9189	337			337	0	279	my @aggregates_in_cluster; # Collect all aggregates inside clusters
9190
9191
9192	337					631	for my $name (sort keys %aggregates) {
9193	52					70	my $aggregate = $aggregates{$name};
9194	52 52					50 102	my ($type, $name) = @{ delete($aggregate->{link}) };
9195	52					73	my $err;
9196							my $router;
9197
9198							# Assure aggregates to be linked to networks only
9199	52	100				112	if ($type ne 'network') {
9200	1					5	err_msg("$aggregate->{name} must not be linked to $type:$name");
9201	1					1	$aggregate->{disabled} = 1;
9202	1					3	next;
9203							}
9204
9205							# Assure aggregate link to exist/disable aggregates without active links
9206	51					62	my $network = $networks{$name};
9207	51	50				91	if (not $network) {
9208	0					0	err_msg("Referencing undefined $type:$name",
9209							" from $aggregate->{name}");
9210	0					0	$aggregate->{disabled} = 1;
9211	0					0	next;
9212							}
9213	51	100				114	if ($network->{disabled}) {
9214	1					2	$aggregate->{disabled} = 1;
9215	1					2	next;
9216							}
9217
9218							# Reference network link in security zone.
9219	50					52	my $zone = $network->{zone};
9220	50					60	$zone->{link} = $network; # only used in cut-netspoc
9221
9222							# Assure aggregate and network private status to be equal
9223	50		50			147	my $private1 = $aggregate->{private} \|\| 'public';
9224	50					50	my $private2 = $network->{private};
9225	50		50			142	$private2 \|\|= 'public';
9226	50	50				84	$private1 eq $private2
9227							or err_msg("$private1 $aggregate->{name} must not be linked",
9228							" to $private2 $type:$name");
9229
9230							# Assure that no other aggregate with same IP and mask exists in cluster
9231	50 50					48 88	my ($ip, $mask) = @{$aggregate}{qw(ip mask)};
9232	50					111	my $key = "$ip/$mask";
9233	50					51	my $cluster = $zone->{zone_cluster};
9234	50	100				97	for my $zone2 ($cluster ? @$cluster : ($zone)) {
9235	55	100				157	if (my $other = $zone2->{ipmask2aggregate}->{$key}) {
9236	1					5	err_msg("Duplicate $other->{name} and $aggregate->{name}",
9237							" in $zone->{name}");
9238							}
9239							}
9240
9241							# Collect aggregates inside clusters
9242	50	100				94	if ($cluster) {
9243	4					5	push(@aggregates_in_cluster, $aggregate);
9244							}
9245
9246							# Use aggregate with ip 0/0 to set attributes of all zones in cluster.
9247							#
9248							# Even NAT is moved to zone for aggregate 0/0 although we
9249							# retain NAT at other aggregates.
9250							# This is an optimization to prevent the creation of many aggregates 0/0
9251							# if only inheritance of NAT from area to network is needed.
9252	50	100				90	if ($mask == 0) {
9253	29					38	for my $attr (qw(has_unenforceable owner nat)) {
9254	87	100				173	if (my $v = delete $aggregate->{$attr}) {
9255	16	100				31	for my $zone2 ($cluster ? @$cluster : ($zone)) {
9256	17					44	$zone2->{$attr} = $v;
9257							}
9258							}
9259							}
9260							}
9261							# Link aggragate and zone (also setting zone{ipmask2aggregate}
9262	50					87	link_aggregate_to_zone($aggregate, $zone, $key);
9263							}
9264
9265							# add aggregate to all zones in the zone cluster
9266	337					416	for my $aggregate (@aggregates_in_cluster) {
9267	4					6	duplicate_aggregate_to_cluster($aggregate);
9268							}
9269	337					305	return;
9270							}
9271							##############################################################################
9272							# Parameter: $aggregate object reference, $implicit flag
9273							# Purpose : Create an aggregate object for every zone inside the zones cluster
9274							# containing the aggregates link-network.
9275							# Comments : From users point of view, an aggregate refers to networks of a zone
9276							# cluster. Internally, an aggregate object represents a set of
9277							# networks inside a zone. Therefeore, every zone inside a cluster
9278							# gets its own copy of the defined aggregate to collect the zones
9279							# networks matching the aggregates IP address.
9280							# TDOD : Aggregate may be a non aggregate network,
9281							# e.g. a network with ip/mask 0/0. ??
9282							sub duplicate_aggregate_to_cluster {
9283	10			10	0	11	my ($aggregate, $implicit) = @_;
9284	10					14	my $cluster = $aggregate->{zone}->{zone_cluster};
9285	10 10					8 16	my ($ip, $mask) = @{$aggregate}{qw(ip mask)};
9286	10					18	my $key = "$ip/$mask";
9287
9288							# Process every zone of the zone cluster
9289	10					13	for my $zone (@$cluster) {
9290	24	100				50	next if $zone->{ipmask2aggregate}->{$key};
9291							# debug("Dupl. $aggregate->{name} to $zone->{name}");
9292
9293							# Create new aggregate object for every zone inside the cluster
9294	12					24	my $aggregate2 = new(
9295							'Network',
9296							name => $aggregate->{name},
9297							is_aggregate => 1,
9298							ip => $aggregate->{ip},
9299							mask => $aggregate->{mask},
9300							);
9301
9302							# Link new aggregate object and cluster
9303	12	100				16	if ($implicit) {
9304	9					12	link_implicit_aggregate_to_zone($aggregate2, $zone, $key);
9305							}
9306							else {
9307	3					4	link_aggregate_to_zone($aggregate2, $zone, $key);
9308							}
9309							}
9310	10					15	return;
9311							}
9312
9313							###############################################################################
9314							# Find aggregate referenced from any:[..].
9315							# Creates new anonymous aggregate if missing.
9316							# If zone is part of a zone_cluster,
9317							# return aggregates for each zone of the cluster.
9318							sub get_any {
9319	184			184	0	188	my ($zone, $ip, $mask) = @_;
9320	184					330	my $key = "$ip/$mask";
9321	184					170	my $cluster = $zone->{zone_cluster};
9322	184	100				330	if (!$zone->{ipmask2aggregate}->{$key}) {
9323
9324							# Check, if there is a network with same IP as the requested
9325							# aggregate. If found, don't create a new aggregate in zone,
9326							# but use the network instead. Otherwise {up} relation
9327							# wouldn't be well defined.
9328	99 127 108	100 100 100				149 417 210	if (my @networks = grep({ $_->{mask} == $mask && $_->{ip} == $ip }
9329	108					83	map { @{ $_->{networks} } }
9330							$cluster ? @$cluster : ($zone)))
9331							{
9332	1	50				3	@networks > 1 and internal_err;
9333	1					2	my ($network) = @networks;
9334	1					1	my $zone2 = $network->{zone};
9335
9336							# Handle $network like an aggregate.
9337	1					2	$zone2->{ipmask2aggregate}->{$key} = $network;
9338
9339							# Create aggregates in cluster, using the name of the network.
9340	1	50				2	duplicate_aggregate_to_cluster($network, 1) if $cluster;
9341							}
9342							else {
9343
9344							# any:[network:x] => any:[ip=i.i.i.i/pp & network:x]
9345	98					135	my $p_ip = print_ip($ip);
9346	98					136	my $prefix = mask2prefix($mask);
9347	98					111	my $name = $zone->{name};
9348	98	100				365	$name =~ s/\[/[ip=$p_ip\/$prefix & / if $prefix != 0;
9349	98					153	my $aggregate = new(
9350							'Network',
9351							name => $name,
9352							is_aggregate => 1,
9353							ip => $ip,
9354							mask => $mask,
9355							);
9356	98	50				175	if (my $private = $zone->{private}) {
9357	0					0	$aggregate->{private} = $private;
9358							}
9359	98					150	link_implicit_aggregate_to_zone($aggregate, $zone, $key);
9360	98	100				207	duplicate_aggregate_to_cluster($aggregate, 1) if $cluster;
9361							};
9362							}
9363	184	100				239	if ($cluster) {
9364	12					79	return get_cluster_aggregates($zone, $ip, $mask);
9365							}
9366							else {
9367	172					529	return $zone->{ipmask2aggregate}->{$key};
9368							}
9369							}
9370
9371							# Get set of aggregates of a zone cluster.
9372							# Ignore zone having no aggregate from unnumbered network.
9373							sub get_cluster_aggregates {
9374	12			12	0	15	my ($zone, $ip, $mask) = @_;
9375	12					20	my $key = "$ip/$mask";
9376							return
9377	12 32 12	50				8 108 17	map { $_->{ipmask2aggregate}->{$key}\|\|() } @{ $zone->{zone_cluster} };
9378							}
9379
9380							###############################################################################
9381							# Purpose : Collects all elements (networks, unmanaged routers, interfaces) of
9382							# a zone object and references the zone in its elements. Sets zone
9383							# property flags and private status.
9384							# Comments : Unnumbered and tunnel networks are not referenced in zone objects,
9385							# as they are no valid src or dst.
9386							sub set_zone1 {
9387	1148			1148	0	1094	my ($network, $zone, $in_interface) = @_;
9388
9389							# Return if network was processed already (= loop was found).
9390	1148	100				1749	if ($network->{zone}) {
9391	36					61	return;
9392							}
9393
9394							# Reference zone in network and vice versa...
9395	1112					1185	$network->{zone} = $zone;
9396	1112	100				2646	if (not($network->{ip} =~ /^(?:unnumbered\|tunnel)$/)) {# no valid src/dst
9397	1076 1076					787 1492	push @{ $zone->{networks} }, $network;
9398							}
9399							# debug("$network->{name} in $zone->{name}");
9400
9401							# Set zone property flags depending on network properties...
9402	1112	100				1904	$network->{ip} eq 'tunnel' and $zone->{is_tunnel} = 1;
9403	1112	100				1578	$network->{has_id_hosts} and $zone->{has_id_hosts} = 1;
9404
9405							# Check network 'private' status and zone 'private' status to be equal.
9406	1112		100			2796	my $private1 = $network->{private} \|\| 'public';
9407	1112	100				1546	if ($zone->{private}) {
9408	230					196	my $private2 = $zone->{private};
9409	230	100				432	if ($private1 ne $private2) {
9410	1					1	my $other = $zone->{networks}->[0];
9411	1					8	err_msg("All networks of $zone->{name} must have",
9412							" identical 'private' status\n",
9413							" - $other->{name}: $private2\n",
9414							" - $network->{name}: $private1");
9415							}
9416							}
9417
9418							# Set zone private status (attribute will be removed if value is 'public')
9419	1112					1122	$zone->{private} = $private1;# TODO: is set in every iteration. else clause?
9420
9421							# Proceed with adjacent elements...
9422	1112 1112					836 1391	for my $interface (@{ $network->{interfaces} }) {
9423	1630	100				3067	next if $interface eq $in_interface; # Ignore Interface we came from.
9424	1400					1237	my $router = $interface->{router};
9425
9426							# If its a zone delimiting router, reference interface in zone and v.v.
9427	1400	100	100			2907	if ($router->{managed} or $router->{semi_managed}) {
9428	1158					1164	$interface->{zone} = $zone;
9429	1158 1158					804 2365	push @{ $zone->{interfaces} }, $interface;
9430							}
9431							else {
9432
9433							#If its an unmanaged router, reference router in zone and v.v.
9434	242	100				391	next if $router->{zone}; # Traverse each unmanaged router only once.
9435	206					223	$router->{zone} = $zone; # added only to prevent double traversal
9436	206 206					163 280	push @{ $zone->{unmanaged_routers} }, $router;
9437
9438							# Recursively add adjacent networks.
9439	206 206					179 257	for my $out_interface (@{ $router->{interfaces} }) {
9440	472	100				1009	next if $out_interface eq $interface;# Ignore IF we came from.
9441	266	50				400	next if $out_interface->{disabled};
9442	266					497	set_zone1($out_interface->{network}, $zone, $out_interface);
9443							}
9444							}
9445							}
9446	1112					1514	return;
9447							}
9448
9449							##############################################################################
9450							# Purpose : Collect zones connected by semi_managed devices into a cluster.
9451							# Comments : Tunnel_zones are not included in zone clusters, because
9452							# - it is useless in rules and
9453							# - we would get inconsistent owner since zone of tunnel
9454							# doesn't inherit from area.
9455							sub set_zone_cluster {
9456	882			882	0	825	my ($zone, $in_interface, $zone_aref) = @_;
9457
9458							# Reference zone in cluster object and vice versa
9459	882	100				1586	push @$zone_aref, $zone if !$zone->{is_tunnel};
9460	882					846	$zone->{zone_cluster} = $zone_aref;
9461
9462	882		100			2068	my $private1 = $zone->{private} \|\| 'public';
9463
9464							# Find zone interfaces connected to semi-managed routers...
9465	882 882					665 1097	for my $interface (@{ $zone->{interfaces} }) {
9466	1158	100				1999	next if $interface eq $in_interface;
9467	1132	100				1579	next if $interface->{main_interface};
9468	1075					929	my $router = $interface->{router};
9469	1075	100				2148	next if $router->{managed};
9470	19	50				33	next if $router->{active_path};
9471	19					28	local $router->{active_path} = 1;
9472
9473							# Process adjacent zones...
9474	19 19					18 25	for my $out_interface (@{ $router->{interfaces} }) {
9475	46	100				96	next if $out_interface eq $interface;
9476	27					25	my $next = $out_interface->{zone};
9477	27	100				46	next if $next->{zone_cluster}; #traverse zones only once
9478	26	50				45	next if $out_interface->{main_interface};
9479
9480							# Check for equal private status.
9481	26		50			68	my $private2 = $next->{private} \|\| 'public';
9482	26	50				39	$private1 eq $private2 or
9483							err_msg("Zones connected by $router->{name}",
9484							" must all have identical 'private' status\n",
9485							" - $zone->{name}: $private1\n",
9486							" - $next->{name}: $private2");
9487
9488							# Add adjacent zone recursively.
9489	26					52	set_zone_cluster($next, $out_interface, $zone_aref);
9490							}
9491							}
9492	882					1009	return;
9493							}
9494
9495							# Two zones are zone_eq, if
9496							# - zones are equal or
9497							# - both belong to the same zone cluster.
9498							sub zone_eq {
9499	12			12	0	16	my ($zone1, $zone2) = @_;
9500	12		33 33			97	return(($zone1->{zone_cluster} \|\| $zone1) eq
9501							($zone2->{zone_cluster} \|\| $zone2));
9502							}
9503
9504							###############################################################################
9505							# Purpose : Collect zones and managed routers of an area object and set a
9506							# reference to the area in its zones and routers.
9507							# For areas with defined borders: Keep track of area borders found
9508							# during area traversal.
9509							# For anchor/auto_border areas: fill {border} and {inclusive_border}
9510							# arrays.
9511							# Returns : undef (or aref of interfaces, if invalid path was found).
9512							sub set_area1 {
9513	186			186	0	179	my ($obj, $area, $in_interface) = @_;
9514
9515	186	100				376	return if $obj->{areas}->{$area}; # Found a loop.
9516
9517	182					272	$obj->{areas}->{$area} = $area;# Find duplicate/overlapping areas or loops
9518
9519	182					219	my $is_zone = is_zone($obj);
9520
9521							# Reference zones and managed routers in the corresponding area
9522	182	100 50	33			336	if ($is_zone) {
9523	125	50				184	if (!$obj->{is_tunnel}) {
9524	125 125					91 164	push @{ $area->{zones} }, $obj;
9525							}
9526							}
9527							elsif ($obj->{managed} \|\| $obj->{routing_only}) {
9528	57 57					46 83	push @{ $area->{managed_routers} }, $obj;
9529							}
9530
9531	182					177	my $auto_border = $area->{auto_border};
9532	182					154	my $lookup = $area->{intf_lookup};
9533
9534	182 182					136 220	for my $interface (@{ $obj->{interfaces} }) {
9535
9536							# Ignore interface we came from.
9537	301	100				641	next if $interface eq $in_interface;
9538
9539							# No further traversal at secondary interfaces
9540	139	100				209	next if $interface->{main_interface};
9541
9542							# For areas with defined borders, check if border was found...
9543	135	100 100				287	if ($lookup->{$interface}) {
9544	13					12	my $is_inclusive = $interface->{is_inclusive};
9545
9546							# Reached border from wrong side or border classification wrong.
9547	13	100	100			59	if ($is_inclusive->{$area} xor !$is_zone) {
9548	2					7	return [ $interface ]; # will be collected to show invalid path
9549							}
9550
9551							# ...mark found border in lookup hash.
9552	11					19	$lookup->{$interface} = 'found';
9553	11					16	next;
9554							}
9555
9556							# For auto_border areas, just collect border/inclusive_border interface
9557							elsif ($auto_border) {
9558	6	100				9	if ($interface->{is_border}) {
9559	2 2	100				2 4	push(@{ $area->{$is_zone ? 'border' : 'inclusive_border'} },
9560							$interface);
9561	2					3	next;
9562							}
9563							}
9564
9565							# Proceed traversal with next element
9566	120	100				166	my $next = $interface->{$is_zone ? 'router' : 'zone'};
9567	120	100				212	if (my $err_path = set_area1($next, $area, $interface)) {
9568	3					4	push @$err_path, $interface; # collect interfaces of invalid path
9569	3					7	return $err_path;
9570							}
9571							}
9572	177					449	return;
9573							}
9574
9575							###############################################################################
9576							# Purpose : Distribute router_attributes from the area definition to the managed
9577							# routers of the area.
9578							sub inherit_router_attributes {
9579	66			66	0	64	my ($area) = @_;
9580
9581							# Check for attributes to be inherited.
9582	66	100				126	my $attributes = $area->{router_attributes} or return;
9583	7	50	33			14	$attributes->{owner} and keys %$attributes == 1 and return; # handled later
9584
9585							#Process all managed routers of the area inherited from.
9586	7 7					7 10	for my $router (@{ $area->{managed_routers} }) {
9587	6					12	for my $key (keys %$attributes) {
9588
9589	12	50				19	next if $key eq 'owner'; # Owner is handled in propagate_owners.
9590
9591							# if attribute exists in router (router or smaller area definition)
9592	12					11	my $val = $attributes->{$key};
9593	12	100				17	if (my $r_val = $router->{$key}) {
9594	8	50	20			37	if ( $r_val eq $val # warn, if attributes are equal
9595							\|\| ref $r_val eq 'ARRAY' && ref $val eq 'ARRAY'
9596							&& aref_eq($r_val, $val))
9597							{
9598	1					6	warn_msg(
9599							"Useless attribute '$key' at $router->{name},\n",
9600							" it was already inherited from $attributes->{name}");
9601							}
9602							}
9603
9604							# Add attribute to the router object if not yet set.
9605							else {
9606	4					10	$router->{$key} = $val;
9607							}
9608							}
9609							}
9610	7					8	return;
9611							}
9612
9613							###############################################################################
9614							# Purpose : Returns true if nat hashes are equal.
9615							sub nat_equal {
9616	23			23	0	22	my ($nat1, $nat2) = @_;
9617
9618							# Check whether nat attributes are different...
9619	23					26	for my $attr (qw(ip mask dynamic hidden identity)) {
9620	50	100	100			184	return if defined $nat1->{$attr} xor defined $nat2->{$attr};
9621	37	100				61	next if !defined $nat1->{$attr};# none of the Nats holds the attribute
9622	20	100				49	return if $nat1->{$attr} ne $nat2->{$attr};# values of attribute differ
9623							}
9624
9625							# ...return true if no difference found.
9626	3					7	return 1;
9627							}
9628							##############################################################################
9629							# Purpose : 1. Generate warning if NAT value of two objects hold the same
9630							# attributes.
9631							# 2. Mark occurence of identity NAT that masks inheritance.
9632							# This is used later to warn on useless identity NAT.
9633							sub check_useless_nat {
9634	23			23	0	29	my ($nat_tag, $nat1, $nat2, $obj1, $obj2) = @_;
9635	23	100				30	if (nat_equal($nat1, $nat2)) {
9636	3					12	warn_msg("Useless nat:$nat_tag at $obj2->{name},\n",
9637							" it is already inherited from $obj1->{name}");
9638							}
9639	23	100				35	if ($nat2->{identity}) {
9640	10					12	$nat2->{is_used} = 1;
9641							}
9642	23					36	return;
9643							}
9644
9645							##############################################################################
9646							# Purpose : Distribute NAT from area to zones.
9647							sub inherit_area_nat {
9648
9649	66			66	0	67	my ($area) = @_;
9650	66	100				154	my $hash = $area->{nat} or return;
9651
9652							# Process every nat definition of area.
9653	5					10	for my $nat_tag (sort keys %$hash) {
9654	6					7	my $nat = $hash->{$nat_tag};
9655
9656							# Distribute nat definitions to every zone of area.
9657	6 6					7 8	for my $zone (@{ $area->{zones} }) {
9658
9659							# Skip zone, if NAT tag exists in zone already...
9660	10	100				17	if (my $z_nat = $zone->{nat}->{$nat_tag}) {
9661
9662							# ... and warn if zones NAT value holds the same attributes.
9663	4					7	check_useless_nat($nat_tag, $nat, $z_nat, $area, $zone);
9664	4					8	next;
9665							}
9666
9667							# Store NAT definition in zone otherwise
9668	6					14	$zone->{nat}->{$nat_tag} = $nat;
9669							# debug "$zone->{name}: $nat_tag from $area->{name}";
9670							}
9671							}
9672	5					8	return;
9673							}
9674
9675							###############################################################################
9676							# Purpose : Assure that areas are processed in the right order and distribute
9677							# area attributes to zones and managed routers.
9678							sub inherit_attributes_from_area {
9679
9680							# Areas can be nested. Proceed from small to larger ones.
9681	337 29 29 29			337	0	556 24 34 43	for my $area (sort { @{ $a->{zones} } <=> @{ $b->{zones} } } @areas) {
9682	66					95	inherit_router_attributes($area);
9683	66					90	inherit_area_nat($area);
9684							}
9685	337					323	return;
9686							}
9687
9688							###############################################################################
9689							# Purpose : Distributes NAT from aggregates and networks to other networks
9690							# in same zone, that are in subnet relation.
9691							# If a network A is subnet of multiple networks B < C,
9692							# then NAT of B is used.
9693							sub inherit_nat_to_subnets_in_zone {
9694	106			106	0	113	my ($net_or_zone, $zone) = @_;
9695	97					148	my ($ip1, $mask1) = is_network($net_or_zone)
9696	106	100				131	? @{$net_or_zone}{qw(ip mask)}
9697							: (0, 0);
9698	106					129	my $hash = $net_or_zone->{nat};
9699	106					215	for my $nat_tag (sort keys %$hash) {
9700	136					159	my $nat = $hash->{$nat_tag};
9701							# debug "inherit $nat_tag from $net_or_zone->{name}";
9702
9703							# Distribute nat definitions to every subnet of supernet, aggregate or zone.
9704	136 136					98 175	for my $network (@{ $zone->{networks} }) {
9705	248 248					174 294	my ($ip2, $mask2) = @{$network}{qw(ip mask)};
9706
9707							# Only process subnets.
9708	248	100				539	$mask2 > $mask1 or next;
9709	55	100				73	match_ip($ip2, $ip1, $mask1) or next;
9710
9711							# Skip network, if NAT tag exists in network already...
9712	33	100 50	33			90	if (my $n_nat = $network->{nat}->{$nat_tag}) {
9713
9714							# ... and warn if networks NAT value holds the
9715							# same attributes.
9716	19					29	check_useless_nat($nat_tag, $nat, $n_nat, $net_or_zone, $network);
9717							}
9718
9719							elsif ($network->{ip} eq 'bridged' and not $nat->{identity}) {
9720	0					0	err_msg("Must not inherit nat:$nat_tag at bridged",
9721							" $network->{name} from $net_or_zone->{name}");
9722							}
9723
9724							# Copy NAT defintion; append name of network.
9725							else {
9726	14					69	my $sub_nat = {
9727							%$nat,
9728
9729							# Needed for error messages.
9730							name => "nat:$nat_tag($network->{name})",
9731							};
9732
9733							# For static NAT from net_or_zone,
9734							# - merge IP from supernet and subnet,
9735							# - adapt mask to size of subnet
9736	14	100				33	if (not $nat->{dynamic}) {
9737
9738							# Take higher bits from NAT IP, lower bits from original IP.
9739	2					3	$sub_nat->{ip} \|= $ip2 & complement_32bit($mask1);
9740	2					2	$sub_nat->{mask} = $mask2;
9741							}
9742
9743	14					33	$network->{nat}->{$nat_tag} = $sub_nat;
9744							}
9745							}
9746							}
9747	106					242	return;
9748							}
9749
9750							sub inherit_nat_in_zone {
9751	337			337	0	367	for my $zone (@zones) {
9752
9753							# Find all networks and aggregates of current zone,
9754							# that have NAT definitions.
9755	1129 882					1503 917	my @nat_supernets = grep({ $_->{nat} }
9756	882					1428	@{ $zone->{networks} },
9757	882					688	values %{ $zone->{ipmask2aggregate} });
9758
9759							# Add zone object instead of aggregate 0/0, because NAT is stored
9760							# at zone in this case.
9761	882	100				1223	my @nat_zone = $zone->{nat} ? ($zone) : ();
9762
9763							# Proceed from smaller to larger objects. (Bigger mask first.)
9764	882 13					1683 23	for my $supernet (sort({ $b->{mask} <=> $a->{mask} } @nat_supernets),
9765							@nat_zone)
9766							{
9767	106					142	inherit_nat_to_subnets_in_zone($supernet, $zone);
9768							}
9769							}
9770	337					317	return;
9771							}
9772
9773							sub cleanup_after_inheritance {
9774
9775							# 1. Remove NAT entries from aggregates.
9776							# These are only used during NAT inheritance.
9777							# 2. Remove identity NAT entries.
9778							# These are only needed during NAT inheritance.
9779	337			337	0	378	for my $network (@networks) {
9780	1165	100				1944	my $href = $network->{nat} or next;
9781	111	100				166	if ($network->{is_aggregate}) {
9782	2					2	delete $network->{nat};
9783	2					5	next;
9784							}
9785	109					166	for my $nat_tag (keys %$href) {
9786	138					135	my $nat_network = $href->{$nat_tag};
9787	138	100				330	$nat_network->{identity} or next;
9788	10					13	delete $href->{$nat_tag};
9789	10	50				33	$nat_network->{is_used} or
9790							warn_msg("Useless identity nat:$nat_tag at $network->{name}");
9791							}
9792							}
9793	337					304	return;
9794							}
9795
9796							sub inherit_attributes {
9797	337			337	0	467	inherit_attributes_from_area();
9798	337					452	inherit_nat_in_zone();
9799	337					421	cleanup_after_inheritance();
9800	337					275	return;
9801							}
9802
9803							##############################################################################
9804							# Purpose : Create a new zone object for every network without a zone
9805							sub set_zones {
9806
9807							# Process networks without a zone
9808	337			337	0	389	for my $network (@networks) {
9809	1112	100				1759	next if $network->{zone};
9810
9811							# Create zone object with name of corresponding aggregate and ip 0/0.
9812	882					1913	my $name = "any:[$network->{name}]";
9813	882					1507	my $zone = new('Zone', name => $name, networks => []);
9814	882					857	push @zones, $zone;
9815
9816							# Collect zone elements...
9817	882					1192	set_zone1($network, $zone, 0);
9818
9819							# Mark zone which consists only of a loopback network.
9820	31					87	$zone->{loopback} = 1
9821	882	100	67			1600	if $network->{loopback} && @{ $zone->{networks} } == 1;
9822
9823							# Attribute {is_tunnel} is set only when zone has only tunnel networks.
9824	882 882	100				682 1422	if (@{ $zone->{networks} }) {# tunnel networks arent referenced in zone
9825	873					884	delete $zone->{is_tunnel};
9826							}
9827
9828							# Remove zone reference from unmanaged routers (no longer needed).
9829	882	100				1432	if (my $unmanaged = $zone->{unmanaged_routers}) {
9830	156					380	delete $_->{zone} for @$unmanaged;
9831							}
9832
9833							# Remove private status, if 'public'
9834	882	100	67			2768	if ($zone->{private} && $zone->{private} eq 'public') {
9835	881					1396	delete $zone->{private};
9836							}
9837							}
9838	337					342	return;
9839							}
9840
9841							##############################################################################
9842							# Purpose : Clusters zones connected by semi_managed routers. References of all
9843							# zones of a cluster are stored in the {zone_cluster} attribute of
9844							# the zones.
9845							# Comments : The {zone_cluster} attribute is only set if the cluster has more
9846							# than one element.
9847							sub cluster_zones {
9848
9849							# Process all unclustered zones.
9850	337			337	0	385	for my $zone (@zones) {
9851	882	100				1335	next if $zone->{zone_cluster};
9852
9853							# Create a new cluster and collect its zones
9854	856					849	my $cluster = [];
9855	856					1072	set_zone_cluster($zone, 0, $cluster);
9856
9857							# delete clusters containing a single network only
9858	856	100				1930	delete $zone->{zone_cluster} if 1 >= @$cluster;
9859
9860							# debug('cluster: ', join(',',map($_->{name}, @{$zone->{zone_cluster}})))
9861							# if $zone->{zone_cluster};
9862							}
9863	337					337	return;
9864							}
9865
9866							###############################################################################
9867							# Purpose : Mark interfaces, which are border of some area, prepare consistency
9868							# check for attributes {border} and {inclusive_border}.
9869							# Comments : Area labeled interfaces are needed to locate auto_borders.
9870							sub prepare_area_borders {
9871	337			337	0	282	my %has_inclusive_borders; # collects all routers with inclusive border IF
9872
9873							# Identify all interfaces which are border of some area
9874	337					391	for my $area (@areas) {
9875	66					75	for my $attribute (qw(border inclusive_border)) {
9876	132	100				317	my $border = $area->{$attribute} or next;
9877	52					55	for my $interface (@$border) {
9878
9879							# Reference delimited area in the interfaces attributes
9880	62					81	$interface->{is_border} = $area; # used for auto borders
9881	62	100				159	if ($attribute eq 'inclusive_border') {
9882	18					35	$interface->{is_inclusive}->{$area} = $area;
9883
9884							# Collect routers with inclusive border interface
9885	18					18	my $router = $interface->{router};
9886	18					54	$has_inclusive_borders{$router} = $router;
9887							}
9888							}
9889							}
9890							}
9891	337					406	return \%has_inclusive_borders;
9892							}
9893
9894							###############################################################################
9895							# Purpose : Collect zones, routers (and interfaces, if no borders defined)
9896							# of an area.
9897							# Returns : undef (or 1, if error was shown)
9898							sub set_area {
9899	66			66	0	72	my ($obj, $area, $in_interface) = @_;
9900	66	100				123	if (my $err_path = set_area1($obj, $area, $in_interface)) {
9901
9902							# Print error path, if errors occurred
9903	2	50				4	push @$err_path, $in_interface if $in_interface;
9904	2					2	my $err_intf = $err_path->[0];
9905	2					2	my $is_inclusive = $err_intf->{is_inclusive};
9906	2	100				6	my $err_obj = $err_intf->{$is_inclusive->{$area} ? 'router' : 'zone'};
9907	2	100				7	my $in_loop = $err_obj->{areas}->{$area} ? ' in loop' : '';
9908	7					20	err_msg("Inconsistent definition of $area->{name}", $in_loop, ".\n",
9909							" It is reached from outside via this path:\n",
9910	2					7	" - ", join("\n - ", map { $_->{name} } reverse @$err_path));
9911	2					4	return 1;
9912							}
9913	64					66	return;
9914							}
9915
9916							###############################################################################s
9917							# Purpose : Set up area objects, assure proper border definitions.
9918							sub set_areas {
9919	337			337	0	388	for my $area (@areas) {
9920	66					101	$area->{zones} = [];
9921	66	100				115	if (my $network = $area->{anchor}) {
9922	17					30	set_area($network->{zone}, $area, 0);
9923							}
9924							else {
9925
9926							# For efficient look up if some IF is a border of current area.
9927	49					70	my $lookup = $area->{intf_lookup} = {};
9928
9929	49					46	my $start;
9930							my $obj1;
9931
9932							# Collect all area delimiting interfaces in border lookup array
9933	49					53	for my $attr (qw(border inclusive_border)) {
9934	98	100				204	my $borders = $area->{$attr} or next;
9935	52 52					52 110	@{$lookup}{@$borders} = @$borders;
9936	52	100				89	next if $start;
9937
9938							# identify start interface and direction for area traversal
9939	49					52	$start = $borders->[0];
9940	49	100				98	$obj1 = $attr eq 'border'
9941							? $start->{zone} # proceed with zone
9942							: $start->{router}; # proceed with router
9943							}
9944
9945							# Collect zones and routers of area and keep track of borders found.
9946	49					80	$lookup->{$start} = 'found';
9947	49					76	my $err = set_area($obj1, $area, $start);
9948	49	100				74	next if $err;
9949
9950							# Assert that all borders were found.
9951	47					51	for my $attr (qw(border inclusive_border)) {
9952	94	100				200	my $borders = $area->{$attr} or next;
9953	49 59	100				65 206	my @bad_intf = grep { $lookup->{$_} ne 'found' } @$borders
9954							or next;
9955	1					4	err_msg("Invalid $attr of $area->{name}:\n - ",
9956	1					3	join("\n - ", map { $_->{name} } @bad_intf));
9957	2					6	$area->{$attr} =
9958	1					2	[ grep { $lookup->{$_} eq 'found' } @$borders ];
9959							}
9960							}
9961
9962							# Check whether area is empty (= consist of a single router)
9963	64 64	100				55 162	@{ $area->{zones} } or
9964							warn_msg("$area->{name} is empty");
9965
9966							# debug("$area->{name}:\n ", join "\n ", map $_->{name}, @{$area->{zones}});
9967							}
9968	337					286	return;
9969							}
9970
9971							###############################################################################
9972							# Purpose : Find subset relation between areas, assure that no duplicate or
9973							# overlapping areas exist
9974							sub find_subset_relations {
9975	337			337	0	264	my %seen; # key:contained area, value: containing area
9976
9977							# Process all zones contained by one or more areas
9978	337					383	for my $zone (@zones) {
9979	882	100				1518	$zone->{areas} or next;
9980
9981							# Sort areas containing zone by ascending size
9982	32 32 32 97	50				28 32 93 250	my @areas = sort({ @{ $a->{zones} } <=> @{ $b->{zones} } \|\|
9983							$a->{name} cmp $b->{name} }#equal size? sort by name
9984	97	50				85	values %{ $zone->{areas} }) or next; # Skip empty hash.
9985
9986							# Take the smallest area.
9987	97					97	my $next = shift @areas;
9988
9989	97					195	while(@areas) {
9990	28					24	my $small = $next;
9991	28					23	$next = shift @areas;
9992	28	100				84	next if $seen{$small}->{$next};# Already identified in other zone.
9993
9994							# Check that each zone of $small is part of $next.
9995	18					18	my $ok = 1;
9996	18 18					17 24	for my $zone (@{ $small->{zones} }) {
9997	28	100				70	if(!$zone->{areas}->{$next}) {
9998	1					1	$ok = 0;
9999	1					5	err_msg("Overlapping $small->{name} and $next->{name}");
10000	1					1	last;
10001							}
10002							}
10003
10004							# check for duplicates
10005	18	100				30	if ($ok) {
10006	17 17 17	100				13 21 28	if (@{ $small->{zones} } == @{ $next->{zones} }) {
10007	1					60	err_msg("Duplicate $small->{name} and $next->{name}");
10008							}
10009
10010							# reference containing area
10011							else {
10012	16					23	$small->{subset_of} = $next;
10013							# debug "$small->{name} < $next->{name}";
10014							}
10015							}
10016
10017							#keep track of processed areas
10018	18					61	$seen{$small}->{$next} = 1;
10019							}
10020							}
10021	337					423	return;
10022							}
10023
10024							#############################################################################
10025							# Purpose : Check, that area subset relations hold for routers:
10026							# : Case 1: If a router R is located inside areas A1 and A2 via
10027							# 'inclusive_border', then A1 and A2 must be in subset relation.
10028							# : Case 2: If area A1 and A2 are in subset relation and A1 includes R,
10029							# then A2 also needs to include R either from 'inclusive_border' or
10030							# R is surrounded by zones located inside A2.
10031							# Comments : This is needed to get consistent inheritance with
10032							# 'router_attributes'.
10033							sub check_routers_in_nested_areas {
10034
10035	337			337	0	325	my ($has_inclusive_borders) = @_;
10036							# Case 1: Identify routers contained by areas via 'inclusive_border'
10037	337					876	for my $router (sort by_name values %$has_inclusive_borders) {
10038
10039							# Sort all areas having this router as inclusive_border by size.
10040	3					4	my @areas =
10041	3 3 12	50				2 12 26	sort({ @{ $a->{zones} } <=> @{ $b->{zones} } \|\| # ascending order
10042							$a->{name} cmp $b->{name} } # equal size? sort by name
10043	12					14	values %{ $router->{areas} });
10044
10045							# Take the smallest area.
10046	12					12	my $next = shift @areas;
10047
10048							# Pairwisely check containing areas for subset relation.
10049	12					30	while(@areas) {
10050	3					7	my $small = $next;
10051	3					3	$next = shift @areas;
10052	3		100			9	my $big = $small->{subset_of} \|\| ''; # extract containing area
10053	3	100				13	next if $next eq $big;
10054	1					7	err_msg("$small->{name} and $next->{name} must be",
10055							" in subset relation,\n because both have",
10056							" $router->{name} as 'inclusive_border'");
10057							}
10058							}
10059
10060							# Case 2: Identify areas in subset relation
10061	337					426	for my $area (@areas) {
10062	66	100				161	my $big = $area->{subset_of} or next;
10063
10064							# Assure routers of the subset area to be located in containing area too
10065	16 16					16 35	for my $router (@{ $area->{managed_routers} }) {
10066	8	100				26	next if $router->{areas}->{$big};
10067	1					6	err_msg("$router->{name} must be located in $big->{name},\n",
10068							" because it is located in $area->{name}\n",
10069							" and both areas are in subset relation\n",
10070							" (use attribute 'inclusive_border')");
10071							}
10072							}
10073	337					309	return;
10074							}
10075
10076							##############################################################################
10077							# Purpose : Delete unused attributes in area objects.
10078							sub clean_areas {
10079	337			337	0	387	for my $area (@areas) {
10080	66					98	delete $area->{intf_lookup};
10081	66 66					57 117	for my $interface (@{ $area->{border} }) {
10082	44					42	delete $interface->{is_border};
10083	44					83	delete $interface->{is_inclusive};
10084							}
10085							}
10086	337					281	return;
10087							}
10088
10089							###############################################################################
10090							# Purpose : Create zones and areas.
10091							sub set_zone {
10092	337			337	0	456	progress('Preparing security zones and areas');
10093	337					474	set_zones();
10094	337					492	cluster_zones();
10095	337					489	check_no_in_acl(); #TODO: place somewhere else?
10096	337					472	my $crosslink_routers = check_crosslink(); #TODO: place somewhere else?
10097	337					494	cluster_crosslink_routers($crosslink_routers); #TODO: place somewhere else?
10098	337					443	my $has_inclusive_borders = prepare_area_borders();
10099	337					481	set_areas();
10100	337					448	find_subset_relations();
10101	337					466	check_routers_in_nested_areas($has_inclusive_borders);
10102	337					427	clean_areas(); # delete unused attributes
10103	337					464	link_aggregates();
10104	337					432	inherit_attributes();
10105	337					513	return;
10106							}
10107
10108							####################################################################
10109							# Virtual interfaces
10110							####################################################################
10111
10112							# Interfaces with identical virtual IP must be located inside the same loop.
10113							sub check_virtual_interfaces {
10114	332			332	0	289	my %seen;
10115	332					382	for my $interface (@virtual_interfaces) {
10116	72	50				115	my $related = $interface->{redundancy_interfaces} or next;
10117
10118							# Loops inside a security zone are not known
10119							# and therefore can't be checked.
10120	72					64	my $router = $interface->{router};
10121	72	100	100			164	next if not($router->{managed} or $router->{semi_managed});
10122
10123	59	100				114	$seen{$related} and next;
10124	28					42	$seen{$related} = 1;
10125
10126	28					20	my $err;
10127	28					33	for my $v (@$related) {
10128	59	50				117	if (not $v->{router}->{loop}) {
10129	0					0	err_msg("Virtual IP of $v->{name}\n",
10130							" must be located inside cyclic sub-graph");
10131	0					0	$err = 1;
10132							}
10133							}
10134	28	50				50	next if $err;
10135	4 59					7 91	equal(map { $_->{loop} } @$related)
10136							or err_msg("Virtual interfaces\n ",
10137	28	100				33	join(', ', map({ $_->{name} } @$related)),
10138							"\n must all be part of the same cyclic sub-graph");
10139							}
10140	332					376	return;
10141							}
10142
10143							####################################################################
10144							# Check pathrestrictions
10145							####################################################################
10146
10147							sub check_pathrestrictions {
10148							RESTRICT:
10149	332			332	0	576	for my $restrict (values %pathrestrictions) {
10150	29					34	my $elements = $restrict->{elements};
10151	29	50				47	next if !@$elements;
10152	29					22	my $deleted;
10153	29					37	for my $obj (@$elements) {
10154
10155							# Interfaces with pathrestriction need to be located
10156							# inside or at the border of cyclic graphs.
10157	60	50	60			155	if (
10158							not( $obj->{loop}
10159							\|\| $obj->{router}->{loop}
10160							\|\| $obj->{zone}->{loop}
10161							\|\| $obj->{disabled})
10162							)
10163							{
10164	0					0	delete $obj->{path_restrict};
10165	0					0	warn_msg("Ignoring $restrict->{name} at $obj->{name}\n",
10166							" because it isn't located inside cyclic graph");
10167	0					0	$obj = undef;
10168	0					0	$deleted = 1;
10169							}
10170							}
10171	29	50				46	if ($deleted) {
10172	0 0					0 0	$elements = $restrict->{elements} = [ grep { $_ } @$elements ];
10173	0	0				0	if (1 == @$elements) {
10174	0					0	$elements = $restrict->{elements} = [];
10175							}
10176							}
10177	29	50				44	next if !@$elements;
10178
10179							# Check for useless pathrestriction where all interfaces
10180							# are located inside a loop with all routers unmanaged.
10181							#
10182							# Some router is managed.
10183	29 60	100 100				32 179	grep({ $_->{router}->{managed} \|\| $_->{router}->{routing_only} }
10184							@$elements) and next;
10185
10186							# Different zones or zone_clusters, hence some router is managed.
10187	6 13 13	50 50				8 32 18	equal(map { $_->{zone_cluster} \|\| $_ } map { $_->{zone} } @$elements)
10188							or next;
10189
10190							# If there exists some neighbour zone or zone_cluster, located
10191							# inside the same loop, then some router is managed.
10192							# Interface is known to have attribute {loop},
10193							# because it is unmanaged and has pathrestriction.
10194	6					8	my $element = $elements->[0];
10195	6					7	my $loop = $element->{loop};
10196	6					5	my $zone = $element->{zone};
10197	6		50			11	my $zone_cluster = $zone->{zone_cluster} \|\| [ $zone ];
10198	6					11	for my $zone1 (@$zone_cluster) {
10199	7 7					4 12	for my $interface (@{ $zone->{interfaces} }) {
10200	12					7	my $router = $interface->{router};
10201	12 12					12 14	for my $interface2 (@{ $router->{interfaces} }) {
10202	22					21	my $zone2 = $interface2->{zone};
10203	22	100				40	next if $zone2 eq $zone;
10204	14	100				25	if (my $cluster2 = $zone2->{zone_cluster}) {
10205	9	100				26	next if $cluster2 eq $zone_cluster;
10206							}
10207	7	100				12	if (my $loop2 = $zone2->{loop}) {
10208	5	50				16	if ($loop eq $loop2) {
10209
10210							# Found other zone in same loop.
10211	5					15	next RESTRICT;
10212							}
10213							}
10214							}
10215							}
10216							}
10217
10218	1					4	warn_msg("Useless $restrict->{name}.\n",
10219							" All interfaces are unmanaged and",
10220							" located inside the same security zone"
10221							);
10222	1					4	$restrict->{elements} = [];
10223							}
10224	332 29 29					408 20 48	push @pathrestrictions, grep({ @{ $_->{elements} } }
10225							values %pathrestrictions);
10226	332					295	return;
10227							}
10228
10229							####################################################################
10230							# Optimize a class of pathrestrictions.
10231							# Find partitions of cyclic graphs that are separated
10232							# by pathrestrictions.
10233							# This allows faster graph traversal.
10234							# When entering a partition, we can already decide,
10235							# if end of path is reachable or not.
10236							####################################################################
10237
10238							sub traverse_loop_part {
10239	332			332	0	346	my ($obj, $in_interface, $mark, $seen) = @_;
10240	332	100				587	return if $obj->{reachable_part}->{$mark};
10241	282	50				375	return if $obj->{active_path};
10242	282					343	local $obj->{active_path} = 1;
10243
10244							# Mark $obj as member of partition.
10245	282					309	$obj->{reachable_part}->{$mark} = 1;
10246							# debug "$obj->{name} in loop part $mark";
10247	282					308	my $is_zone = is_zone($obj);
10248	282 282					231 333	for my $interface (@{ $obj->{interfaces} }) {
10249	936	100				1665	next if $interface eq $in_interface;
10250	654	100				967	next if $interface->{main_interface};
10251	402	100				611	if (my $hash = $seen->{$interface}) {
10252	119	100				150	my $current = $is_zone ? 'zone' : 'router';
10253	119					214	$hash->{$current} = $mark;
10254							}
10255							else {
10256	283	100				432	next if !$interface->{loop};
10257	227	100				292	my $next = $interface->{$is_zone ? 'router' : 'zone'};
10258	227					297	traverse_loop_part($next, $interface, $mark, $seen);
10259							}
10260							}
10261	282					452	return;
10262							}
10263
10264							# Find partitions of a cyclic graph that are separated by pathrestrictions.
10265							# Mark each found partition with a distinct number.
10266							sub optimize_pathrestrictions {
10267	332			332	0	291	my $mark = 1;
10268	332					355	for my $restrict (@pathrestrictions) {
10269	56					59	my $elements = $restrict->{elements};
10270
10271							# Create a hash with all elements as key.
10272							# Used for efficient lookup, if some interface
10273							# is part of current pathrestriction.
10274							# Value is an initially empty hash.
10275							# Keys 'router' and 'zone' are added during traversal.
10276							# Key indicates if element was reached from router or network.
10277							# Value is $mark of the adjacent partition.
10278	56					61	my $seen = {};
10279	56					62	for my $interface (@$elements) {
10280	117					238	$seen->{$interface} = {};
10281							}
10282
10283							# Traverse loop starting from each element of pathrestriction
10284							# in both directions.
10285	56					52	my $start_mark = $mark;
10286	56					58	for my $interface (@$elements) {
10287	117					142	my $reached = $seen->{$interface};
10288	117					117	for my $direction (qw(zone router)) {
10289
10290							# This side of the interface has already been entered
10291							# from some previously found partition.
10292	234	100				423	next if $reached->{$direction};
10293	115					112	my $obj = $interface->{$direction};
10294
10295							# Ignore interface at border of loop in direction
10296							# leaving the loop.
10297	115	100				187	if (!$obj->{loop}) {
10298	10					13	$reached->{$direction} = 'none';
10299	10					13	next;
10300							}
10301	105					113	$reached->{$direction} = $mark;
10302	105					126	traverse_loop_part($obj, $interface, $mark, $seen);
10303	105					137	$mark++;
10304							}
10305							}
10306
10307							# Analyze found partitions.
10308
10309							# If only a single partition was found, nothing can be optimized.
10310	56	100				114	next if $mark <= $start_mark + 1;
10311
10312							# No outgoing restriction needed for a pathrestriction surrounding a
10313							# single zone. A rule from zone to zone would be unenforceable anyway.
10314							#
10315							# But this restriction is needed for one special case:
10316							# src=zone, dst=interface:r.zone
10317							# We must not enter router:r from outside the zone.
10318							# if (equal(map { $_->{zone} } @$elements)) {
10319							# $seen->{$_}->{router} = 'none' for @$elements;
10320							# }
10321
10322							# Collect interfaces at border of newly found partitions.
10323	47					45	my $has_interior;
10324	47					48	for my $interface (@$elements) {
10325	98					121	my $reached = $seen->{$interface};
10326
10327							# Check for pathrestriction inside a partition.
10328	98	50	33			239	if ($reached->{zone} eq $reached->{router} &&
10329							$reached->{zone} ne 'none')
10330							{
10331	0					0	$has_interior++;
10332							}
10333							else {
10334	98					97	for my $direction (qw(zone router)) {
10335	196					194	my $mark = $reached->{$direction};
10336	196	50				263	next if $mark eq 'none';
10337	196					169	my $obj = $interface->{$direction};
10338	196 196					155 604	push @{ $interface->{reachable_at}->{$obj} }, $mark;
10339							# debug "$interface->{name}: $direction $mark";
10340							}
10341							}
10342							}
10343
10344							# Original pathrestriction is needless, if all interfaces are
10345							# border of some partition. The restriction is implemented by
10346							# the new attribute {reachable_at}.
10347	47	50				78	if (!$has_interior) {
10348	47					54	for my $interface (@$elements) {
10349							# debug "remove $restrict->{name} from $interface->{name}";
10350	98	50				139	aref_delete($interface->{path_restrict}, $restrict) or
10351							internal_err("Can't remove $restrict->{name}",
10352							" from $interface->{name}");
10353
10354							# Delete empty array to speed up checks in cluster_path_mark.
10355	98 98	100				77 161	if (!@{ $interface->{path_restrict} }) {
10356	95					242	delete $interface->{path_restrict};
10357							}
10358							}
10359							}
10360							else {
10361							# debug "Can't opt. $restrict->{name}, has $has_interior interior";
10362							}
10363							}
10364	332					300	return;
10365							}
10366
10367							####################################################################
10368							# Set paths for efficient topology traversal
10369							####################################################################
10370
10371							# Parameters:
10372							# $obj: a managed or semi-managed router or a zone
10373							# $to_zone1: interface of $obj; go this direction to reach zone1
10374							# $distance: distance to zone1
10375							# Return values:
10376							# 1. maximal value of $distance used in current subtree.
10377							# 2.
10378							# - undef: found path is not part of a loop
10379							# - loop-marker:
10380							# - found path is part of a loop
10381							# - a hash, which is referenced by all members of the loop
10382							# with this attributes:
10383							# - exit: that node of the loop where zone1 is reached
10384							# - distance: distance of the exit node + 1.
10385							sub setpath_obj;
10386
10387							sub setpath_obj {
10388	1505			1505	0	1427	my ($obj, $to_zone1, $distance) = @_;
10389
10390							# debug("--$distance: $obj->{name} --> ". ($to_zone1 && $to_zone1->{name}));
10391	1505	100				2123	if ($obj->{active_path}) {
10392
10393							# Found a loop; this is possibly exit of the loop to zone1.
10394							# Generate unique loop marker which references this object.
10395							# Distance is needed for cluster navigation.
10396							# We need a copy of the distance value inside the loop marker
10397							# because distance at object is reset later to the value of the
10398							# cluster exit object.
10399							# We must use an intermediate distance value for cluster_navigation
10400							# to work.
10401	119					123	my $new_distance = $obj->{distance} + 1;
10402	119					278	my $loop = $to_zone1->{loop} = {
10403							exit => $obj,
10404							distance => $new_distance,
10405							};
10406	119					187	return ($new_distance, $loop);
10407							}
10408
10409							# Mark current path for loop detection.
10410	1386					1690	local $obj->{active_path} = 1;
10411	1386					1332	$obj->{distance} = $distance;
10412	1386					1045	my $max_distance = $distance;
10413
10414	1386	100				1527	my $get_next = is_router($obj) ? 'zone' : 'router';
10415	1386 1386					1204 1718	for my $interface (@{ $obj->{interfaces} }) {
10416
10417							# Ignore interface where we reached this obj.
10418	2316	100				4599	next if $interface eq $to_zone1;
10419
10420							# Ignore interface which is the other entry of a loop which is
10421							# already marked.
10422	1277	100				1859	next if $interface->{loop};
10423	1158					1126	my $next = $interface->{$get_next};
10424
10425							# Increment by 2 because we need an intermediate value above.
10426	1158					1981	(my $max, my $loop) = setpath_obj($next, $interface, $distance + 2);
10427	1158	100				1726	$max_distance = $max if $max > $max_distance;
10428	1158	100				1270	if ($loop) {
10429	316					279	my $loop_obj = $loop->{exit};
10430
10431							# Found exit of loop in direction to zone1.
10432	316	100 100				636	if ($obj eq $loop_obj) {
10433
10434							# Mark with a different marker linking to itself.
10435							# If current loop is part of a cluster,
10436							# this marker will be overwritten later.
10437							# Otherwise this is the exit of a cluster of loops.
10438	61		100			237	$obj->{loop} \|\|= { exit => $obj, distance => $distance, };
10439							}
10440
10441							# Found intermediate loop node which was marked before.
10442							elsif (my $loop2 = $obj->{loop}) {
10443	58	50				103	if ($loop ne $loop2) {
10444	58	100				83	if ($loop->{distance} < $loop2->{distance}) {
10445	10					9	$loop2->{redirect} = $loop;
10446	10					13	$obj->{loop} = $loop;
10447							}
10448							else {
10449	48					60	$loop->{redirect} = $loop2;
10450							}
10451							}
10452							}
10453
10454							# Found intermediate loop node.
10455							else {
10456	197					222	$obj->{loop} = $loop;
10457							}
10458	316					561	$interface->{loop} = $loop;
10459							}
10460							else {
10461
10462							# Continue marking loop-less path.
10463	842					1483	$interface->{main} = $obj;
10464							}
10465							}
10466	1386	100	100			3117	if ($obj->{loop} and $obj->{loop}->{exit} ne $obj) {
10467	197					372	return ($max_distance, $obj->{loop});
10468
10469							}
10470							else {
10471	1189					1288	$obj->{main} = $to_zone1;
10472	1189					1923	return $max_distance;
10473							}
10474							}
10475
10476							# Find cluster of directly connected loops.
10477							# Find exit node of the cluster in direction to zone1;
10478							# Its loop attribute has a reference to the node itself.
10479							# Add this exit node as marker to all loops belonging to the cluster.
10480							sub set_loop_cluster {
10481	316			316	0	232	my ($loop) = @_;
10482	316	100				409	if (my $marker = $loop->{cluster_exit}) {
10483	197					190	return $marker;
10484							}
10485							else {
10486	119					104	my $exit = $loop->{exit};
10487
10488							# Exit node has loop marker which references the node itself.
10489	119	100				252	if ($exit->{loop} eq $loop) {
10490
10491							# debug("Loop $exit->{name},$loop->{distance} is in cluster $exit->{name}");
10492	58					96	return $loop->{cluster_exit} = $exit;
10493							}
10494							else {
10495	61					120	my $cluster = set_loop_cluster($exit->{loop});
10496
10497							# debug("Loop $exit->{name},$loop->{distance} is in cluster $cluster->{name}");
10498	61					98	return $loop->{cluster_exit} = $cluster;
10499							}
10500							}
10501							}
10502
10503							sub setpath {
10504	337			337	0	481	progress('Preparing fast path traversal');
10505
10506	337	100				554	@zones or fatal_err("Topology seems to be empty");
10507	332 690	100				372 1711	my @path_routers = grep { $_->{managed} \|\| $_->{semi_managed} } @routers;
10508	332					314	my $start_distance = 0;
10509
10510							# Find one or more connected partitions in whole topology.
10511	332					398	for my $obj (@zones, @path_routers) {
10512	1366	100	100			3365	next if $obj->{main} or $obj->{loop};
10513
10514							# Take an arbitrary obj from @zones, name it "zone1".
10515	347					306	my $zone1 = $obj;
10516
10517							# Starting with zone1, do a traversal of all connected nodes,
10518							# to find a path from every zone and router to zone1.
10519							# Second parameter is used as placeholder for a not existing
10520							# starting interface.
10521							# Value must be "false" and unequal to any interface.
10522							# Third parameter is distance from $zone1 to $zone1.
10523	347					506	my $max = setpath_obj($zone1, '', $start_distance);
10524	347					456	$start_distance = $max + 1;
10525							}
10526
10527	332					430	for my $obj (@zones, @path_routers) {
10528	1366	100				2236	my $loop = $obj->{loop} or next;
10529
10530							# Check all zones and routers located inside a cyclic
10531							# graph. Propagate loop exit into sub-loops.
10532	255					404	while (my $next = $loop->{redirect}) {
10533
10534							# debug("Redirect: $loop->{exit}->{name} -> $next->{exit}->{name}");
10535	44					76	$loop = $next;
10536							}
10537	255					224	$obj->{loop} = $loop;
10538
10539							# Mark connected loops with cluster exit.
10540	255					283	set_loop_cluster($loop);
10541
10542							# Set distance of loop objects to value of cluster exit.
10543	255					336	$obj->{distance} = $loop->{cluster_exit}->{distance};
10544							}
10545	332					387	for my $router (@path_routers) {
10546	484 484					384 601	for my $interface (@{ $router->{interfaces} }) {
10547	1138	100				2070	if (my $loop = $interface->{loop}) {
10548	316					464	while (my $next = $loop->{redirect}) {
10549	152					213	$loop = $next;
10550							}
10551	316					447	$interface->{loop} = $loop;
10552							}
10553							}
10554							}
10555
10556							# This is called here and not at link_topology because it needs
10557							# attribute {loop}.
10558	332					533	check_pathrestrictions();
10559	332					419	check_virtual_interfaces();
10560	332					418	optimize_pathrestrictions();
10561	332					361	return;
10562							}
10563
10564							####################################################################
10565							# Efficient path traversal.
10566							####################################################################
10567
10568							my %obj2path;
10569
10570							sub get_path {
10571	1147			1147	0	929	my ($obj) = @_;
10572	1147					1051	my $type = ref $obj;
10573	1147					789	my $result;
10574	1147	100 100 100 100 100 50				2338	if ($type eq 'Network') {
10575	435					441	$result = $obj->{zone};
10576							}
10577							elsif ($type eq 'Subnet') {
10578	71					87	$result = $obj->{network}->{zone};
10579							}
10580							elsif ($type eq 'Interface') {
10581	192					180	my $router = $obj->{router};
10582	192	100	100			440	if ($router->{managed} \|\| $router->{semi_managed}) {
10583
10584							# If this is a secondary interface, we can't use it to enter
10585							# the router, because it has an active pathrestriction attached.
10586							# But it doesn't matter if we use the main interface instead.
10587	131		67			278	$obj = $obj->{main_interface} \|\| $obj;
10588
10589							# Special handling needed if $src or $dst is interface
10590							# which has pathrestriction attached.
10591	131	100	100			378	if ($obj->{path_restrict} \|\| $obj->{reachable_at}) {
10592	40					41	$result = $obj;
10593							}
10594							else {
10595	91					106	$result = $obj->{router};
10596							}
10597							}
10598							else {
10599	61					80	$result = $obj->{network}->{zone};
10600							}
10601							}
10602
10603							# This is used, if called from path_auto_interfaces.
10604							elsif ($type eq 'Router') {
10605	18	100	100			53	if ($obj->{managed} \|\| $obj->{semi_managed}) {
10606	9					11	$result = $obj;
10607							}
10608							else {
10609	9					13	$result = $obj->{interfaces}->[0]->{network}->{zone};
10610							}
10611							}
10612
10613							# This is used, if path_walk is called from find_active_routes.
10614							elsif ($type eq 'Zone') {
10615	426					367	$result = $obj;
10616							}
10617
10618							# This is used, if expand_services without convert_hosts.
10619							elsif ($type eq 'Host') {
10620	5					8	$result = $obj->{network}->{zone};
10621							}
10622							else {
10623	0					0	internal_err("unexpected $obj->{name}");
10624							}
10625
10626							# debug("get_path: $obj->{name} -> $result->{name}");
10627	1147					3103	return($obj2path{$obj} = $result);
10628							}
10629
10630							# Converts hash key of reference back to reference.
10631							my %key2obj;
10632
10633							sub cluster_path_mark1;
10634
10635							sub cluster_path_mark1 {
10636	321			321	0	336	my ($obj, $in_intf, $end, $end_intf, $path_tuples, $loop_leave, $navi) = @_;
10637	321					256	my $pathrestriction = $in_intf->{path_restrict};
10638	321					252	my $reachable_at = $in_intf->{reachable_at};
10639
10640							# debug("cluster_path_mark1: obj: $obj->{name},
10641							# in_intf: $in_intf->{name} to: $end->{name}");
10642
10643							# Check for second occurrence of path restriction.
10644	321	100				426	if ($pathrestriction) {
10645	53					57	for my $restrict (@$pathrestriction) {
10646	40	100				75	if ($restrict->{active_path}) {
10647
10648							# debug(" effective $restrict->{name} at $in_intf->{name}");
10649	19					54	return 0;
10650							}
10651							}
10652							}
10653
10654							# Handle optimized pathrestriction.
10655							# Check if $end_intf is located outside of current reachable_part.
10656							# This must be checked before checking that $end has been reached,
10657	302	100	100			731	if ($reachable_at && $end_intf && $end_intf ne $in_intf) {
10658	28	50				56	if (my $reachable = $reachable_at->{$obj}) {
10659	28					24	my $other = $end_intf->{zone};
10660
10661							# $other inside loop
10662	28	100				41	if ($other->{loop}) {
10663	27					22	my $has_mark = $other->{reachable_part};
10664	27					31	for my $mark (@$reachable) {
10665	27	100				62	if (!$has_mark->{$mark}) {
10666							# debug(" unreachable: $other->{name}",
10667							# " from $in_intf->{name} to $obj->{name}");
10668	10					33	return 0;
10669							}
10670							}
10671							}
10672
10673							# $end_intf at border of loop, $other outside of loop.
10674							# In this case, {reachable_part} isn't set at $other.
10675							# If partition starting at $in_intf also starts at $end_intf,
10676							# then $other can't be reached.
10677							else {
10678	1	50				3	if (my $reachable_at2 = $end_intf->{reachable_at}) {
10679	0	0				0	if (my $reachable2 = $reachable_at2->{$end_intf->{router}}) {
10680	0	0				0	if (intersect($reachable, $reachable2)) {
10681							# debug(" unreachable2: $other->{name}",
10682							# " from $in_intf->{name} to $obj->{name}");
10683	0					0	return 0;
10684							}
10685							}
10686							}
10687							}
10688							}
10689							}
10690
10691							# Don't walk loops.
10692	292	100				409	if ($obj->{active_path}) {
10693
10694							# debug(" active: $obj->{name}");
10695	2					5	return 0;
10696							}
10697
10698							# Found a path to router or zone.
10699	290	100				517	if ($obj eq $end) {
10700
10701							# Mark interface where we leave the loop.
10702	116					121	push @$loop_leave, $in_intf;
10703
10704							# debug(" leave: $in_intf->{name} -> $end->{name}");
10705	116					244	return 1;
10706							}
10707
10708							# Handle optimized pathrestriction.
10709	174	100				234	if ($reachable_at) {
10710	73	100				133	if (my $reachable = $reachable_at->{$obj}) {
10711	70	100				87	my $end_node = $end_intf ? $end_intf->{zone} : $end;
10712	70					58	my $has_mark = $end_node->{reachable_part};
10713	70					74	for my $mark (@$reachable) {
10714	70	100				136	if (!$has_mark->{$mark}) {
10715							# debug(" unreachable3: $end_node->{name}",
10716							# " from $in_intf->{name} to $obj->{name}");
10717	34					104	return 0;
10718							}
10719							}
10720							}
10721							}
10722
10723							# Mark current path for loop detection.
10724	140					180	local $obj->{active_path} = 1;
10725							# debug "activated $obj->{name}";
10726
10727							# Mark first occurrence of path restriction.
10728	140	100				184	if ($pathrestriction) {
10729	13					14	for my $restrict (@$pathrestriction) {
10730
10731							# debug(" enabled $restrict->{name} at $in_intf->{name}");
10732	13					19	$restrict->{active_path} = 1;
10733							}
10734							}
10735
10736	140	100				167	my $get_next = is_router($obj) ? 'zone' : 'router';
10737	140					131	my $success = 0;
10738
10739							# Fill hash for restoring reference from hash key.
10740	140					188	$key2obj{$in_intf} = $in_intf;
10741	140					180	my $allowed = $navi->{ $obj->{loop} };
10742	140 140					115 179	for my $interface (@{ $obj->{interfaces} }) {
10743	386	100				717	next if $interface eq $in_intf;
10744
10745							# As optimization, ignore secondary interface early.
10746	246	100				376	next if $interface->{main_interface};
10747	188					157	my $loop = $interface->{loop};
10748	188	50				300	$allowed or internal_err("Loop with empty navigation");
10749	188	100	67			481	next if not $loop or not $allowed->{$loop};
10750	172					167	my $next = $interface->{$get_next};
10751							# debug "Try $obj->{name} -> $next->{name}";
10752	172	100				310	if (
10753							cluster_path_mark1(
10754							$next, $interface, $end, $end_intf,
10755							$path_tuples, $loop_leave, $navi
10756							)
10757							)
10758							{
10759
10760							# Found a valid path from $next to $end.
10761	119					148	$key2obj{$interface} = $interface;
10762	119					144	$path_tuples->{$in_intf}->{$interface} = is_router($obj);
10763
10764							# debug(" loop: $in_intf->{name} -> $interface->{name}");
10765	119					214	$success = 1;
10766							}
10767							}
10768							# debug "deactivated $obj->{name}";
10769	140	100				205	if ($pathrestriction) {
10770	13					13	for my $restrict (@$pathrestriction) {
10771
10772							# debug(" disabled $restrict->{name} at $in_intf->{name}");
10773	13					19	$restrict->{active_path} = undef;
10774							}
10775							}
10776	140					347	return $success;
10777							}
10778
10779							# Optimize navigation inside a cluster of loops.
10780							# Mark each loop marker
10781							# with the allowed loops to be traversed to reach $to.
10782							# The direction is given as a loop object.
10783							# It can be used to look up interfaces which reference
10784							# this loop object in attribute {loop}.
10785							# Return value:
10786							# A hash with pairs: object -> loop-marker
10787							sub cluster_navigation {
10788	75			75	0	73	my ($from, $to) = @_;
10789	75					71	my $from_loop = $from->{loop};
10790	75					63	my $to_loop = $to->{loop};
10791
10792							# debug("Navi: $from->{name}, $to->{name}");
10793
10794	75					63	my $navi;
10795	75	50	100			182	if (($navi = $from->{navi}->{$to}) and scalar keys %$navi) {
10796
10797							# debug(" Cached");
10798	3					8	return $navi;
10799							}
10800	72					139	$navi = $from->{navi}->{$to} = {};
10801
10802	72					68	while (1) {
10803	135	100 100				272	if ($from_loop eq $to_loop) {
10804	72	100				158	last if $from eq $to;
10805	11					23	$navi->{$from_loop}->{$from_loop} = 1;
10806
10807							# debug("- Eq: $from_loop->{exit}->{name}$from_loop to itself");
10808
10809							# Path $from -> $to traverses $from_loop and $exit_loop.
10810							# Inside $exit_loop, enter only $from_loop, but not from other loops.
10811	11					13	my $exit_loop = $from_loop->{exit}->{loop};
10812	11					20	$navi->{$exit_loop}->{$from_loop} = 1;
10813
10814							# debug("- Add $from_loop->{exit}->{name}$from_loop to exit $exit_loop->{exit}->{name}$exit_loop");
10815	11					18	last;
10816							}
10817							elsif ($from_loop->{distance} >= $to_loop->{distance}) {
10818	18					35	$navi->{$from_loop}->{$from_loop} = 1;
10819
10820							# debug("- Fr: $from_loop->{exit}->{name}$from_loop to itself");
10821	18					20	$from = $from_loop->{exit};
10822	18					22	$from_loop = $from->{loop};
10823							}
10824							else {
10825	45					99	$navi->{$to_loop}->{$to_loop} = 1;
10826
10827							# debug("- To: $to_loop->{exit}->{name}$to_loop to itself");
10828	45					53	$to = $to_loop->{exit};
10829	45					37	my $entry_loop = $to->{loop};
10830	45					97	$navi->{$entry_loop}->{$to_loop} = 1;
10831
10832							# debug("- Add $to_loop->{exit}->{name}$to_loop to entry $entry_loop->{exit}->{name}$entry_loop");
10833	45					54	$to_loop = $entry_loop;
10834							}
10835							}
10836	72					152	return $navi;
10837							}
10838
10839							# Mark paths inside a cluster of loops.
10840							# $from and $to are entry and exit objects inside the cluster.
10841							# The cluster is entered at interface $from_in and left at interface $to_out.
10842							# For each pair of $from / $to, we collect attributes:
10843							# {loop_enter}: interfaces of $from, where the cluster is entered,
10844							# {path_tuples}: tuples of interfaces, which describe all valid paths,
10845							# {loop_leave}: interfaces of $to, where the cluster is left.
10846							# Return value is true if a valid path was found.
10847							#
10848							# $from_store is the starting object of the whole path.
10849							# If the path starts at an interface of a loop and it has a pathrestriction attached,
10850							# $from_store contains this interface.
10851							sub cluster_path_mark {
10852	197			197	0	205	my ($from, $to, $from_in, $to_out, $from_store, $to_store) = @_;
10853
10854							# This particular path through this sub-graph is already known.
10855	197	50				362	return 1 if $from_in->{path}->{$to_store};
10856
10857							# Start and end interface or undef.
10858							# It is set, if the path starts / ends
10859							# - at an interface inside the loop or
10860							# - at an interface at the border of the loop
10861							# (an interface of a router/zone inside the loop)
10862							# - this interface has a pathrestriction attached.
10863	197					146	my ($start_intf, $end_intf);
10864
10865							# Check, if loop is entered or left at interface with pathrestriction.
10866							# - is $from_store located inside or at border of current loop?
10867							# - does $from_in at border of current loop have pathrestriction ?
10868							# dito for $to_store and $to_out.
10869	0					0	my ($start_store, $end_store);
10870	197	100 100	25 25			234	if (is_interface($from_store)
10871							and ($from_store->{router} eq $from or $from_store->{zone} eq $from))
10872							{
10873	37					28	$start_intf = $from_store;
10874	37					28	$start_store = $from_store;
10875							}
10876							elsif ($from_in
10877							and ($from_in->{path_restrict} or $from_in->{reachable_at}))
10878							{
10879	7					7	$start_store = $from_in;
10880							}
10881							else {
10882	153					131	$start_store = $from;
10883							}
10884	197	100 100	25 50			270	if (is_interface($to_store)
10885							and ($to_store->{router} eq $to or $to_store->{zone} eq $to))
10886							{
10887	48					37	$end_intf = $to_store;
10888	48					40	$end_store = $to_store;
10889							}
10890							elsif ($to_out and ($to_out->{path_restrict} or $to_out->{reachable_at})) {
10891	2					3	$end_store = $to_out;
10892							}
10893							else {
10894	147					121	$end_store = $to;
10895							}
10896
10897	197					177	my $success = 1;
10898	197					171	my $from_interfaces = $from->{interfaces};
10899
10900							# debug("cluster_path_mark: $start_store->{name} -> $end_store->{name}");
10901
10902							# Activate pathrestriction of interface at border of loop, if path starts
10903							# or ends outside the loop and enters the loop at such an interface.
10904	197	100	80			724	if ( $from_in
10905							and not $from_in->{loop}
10906							and (my $restrictions = $from_in->{path_restrict})
10907							and not $start_intf)
10908							{
10909	7					9	for my $restrict (@$restrictions) {
10910	7					12	$restrict->{active_path} = 1;
10911							}
10912							}
10913	197	100	80			417	if ( $to_out
10914							and not $to_out->{loop}
10915							and (my $restrictions = $to_out->{path_restrict})
10916							and not $end_intf)
10917							{
10918	2					7	for my $restrict (@$restrictions) {
10919	2	50				6	if ($restrict->{active_path}) {
10920
10921							# Pathrestriction is applied to both, incoming and outgoing interface.
10922							# This prevents traffic through loop.
10923	0					0	$success = 0;
10924							}
10925	2					4	$restrict->{active_path} = 1;
10926							}
10927							}
10928
10929							# Check optimized pathrestriction for path starting inside or
10930							# outside the loop.
10931							REACHABLE:
10932							{
10933
10934							# Check if end node is reachable.
10935							# Interface with pathrestriction belongs to zone.
10936	197 197	100				141 253	my $end_node = $end_intf ? $end_intf->{zone} : $to;
10937
10938							# $start_intf is directly connected to $end_node.
10939							# This must be handled as special case, because
10940							# optimized pathrestriction doesn't prevent path through router.
10941							# Ignore all interfaces except direction to zone.
10942	197	100	100			380	if ($start_intf && $start_intf->{zone} eq $end_node) {
10943	11					14	$from_interfaces = [ $start_intf ];
10944	11					14	last REACHABLE;
10945							}
10946
10947							# If path starts at interface of loop, then ignore restriction
10948							# in direction to zone, hence check only the router.
10949	186	100				204	my $start_node = $start_intf ? $start_intf->{router} : $from;
10950	186		67			387	my $intf = $start_intf \|\| $from_in;
10951	186	100				379	my $reachable_at = $intf->{reachable_at} or last REACHABLE;
10952	7	50				13	my $reachable = $reachable_at->{$start_node} or last REACHABLE;
10953	7					6	my $has_mark = $end_node->{reachable_part};
10954	7					9	for my $mark (@$reachable) {
10955	7	100				11	if (!$has_mark->{$mark}) {
10956	4	50				5	if ($start_intf) {
10957
10958							# Ignore all interfaces except direction to zone
10959	4					5	$from_interfaces = [ $start_intf ];
10960							}
10961							else {
10962	0					0	$success = 0;
10963							}
10964	4					6	last;
10965							}
10966							}
10967	7	50	33			21	if ($success && $start_intf) {
10968
10969							# Temporarily disable optimized pathrestriction in
10970							# direction to zone.
10971	7					7	my $zone = $start_intf->{zone};
10972	7					19	$intf->{saved_reachable_at_zone} = delete $reachable_at->{$zone};
10973							}
10974							}
10975
10976							# If start / end interface is part of a group of virtual
10977							# interfaces (VRRP, HSRP),
10978							# prevent traffic through other interfaces of this group.
10979	197					209	for my $intf ($start_intf, $end_intf) {
10980	394	100				615	next if !$intf;
10981	85	100				156	if (my $interfaces = $intf->{redundancy_interfaces}) {
10982	25					24	for my $interface (@$interfaces) {
10983	50	100				102	next if $interface eq $intf;
10984	25 25					20 60	push @{ $interface->{path_restrict} },
10985							$global_active_pathrestriction;
10986							}
10987							}
10988							}
10989
10990							# Handle special case where path starts or ends at an interface
10991							# with pathrestriction.
10992							# If the router is left / entered via the same interface, ignore
10993							# the PR. If the router is left / entered via some other
10994							# interface, add the PR of the start- / end interface to the other
10995							# interface.
10996	197					210	for my $intf ($start_intf, $end_intf) {
10997	394	100				580	next if !$intf;
10998	85					72	my $router = $intf->{router};
10999	85	100	100			275	next if !($router eq $from \|\| $router eq $to);
11000	83	100				186	my $removed = delete $intf->{path_restrict} or next;
11001	45					48	$intf->{saved_path_restrict} = $removed;
11002	45 45					37 59	for my $interface (@{ $router->{interfaces} }) {
11003	161	100				295	next if $interface eq $intf;
11004	116					122	my $orig =
11005							$interface->{saved_path_restrict} =
11006							$interface->{path_restrict};
11007	116	100				121	if ($orig) {
11008	3	50				6	if (intersect($orig, $removed)) {
11009	3					11	$interface->{path_restrict} =
11010							[ $global_active_pathrestriction ];
11011							}
11012							else {
11013	0					0	$interface->{path_restrict} = [ @$orig, @$removed ];
11014							}
11015							}
11016							else {
11017	113					161	$interface->{path_restrict} = $removed;
11018							}
11019							}
11020							}
11021
11022							BLOCK:
11023							{
11024	197 197	50				178 267	last BLOCK if not $success;
11025	197					152	$success = 0;
11026
11027	197					325	$from_in->{loop_entry}->{$to_store} = $start_store;
11028	197					279	$start_store->{loop_exit}->{$to_store} = $end_store;
11029
11030							# Path from $start_store to $end_store inside cyclic graph
11031							# has been marked already.
11032	197	100				383	if ($start_store->{loop_enter}->{$end_store}) {
11033	122					92	$success = 1;
11034	122					134	last BLOCK;
11035							}
11036
11037	75					84	my $loop_enter = [];
11038	75					83	my $path_tuples = {};
11039	75					70	my $loop_leave = [];
11040
11041	75	50				104	my $navi = cluster_navigation($from, $to)
11042							or internal_err("Empty navi");
11043
11044							# use Dumpvalue;
11045							# Dumpvalue->new->dumpValue($navi);
11046
11047							# Mark current path for loop detection.
11048	75					120	local $from->{active_path} = 1;
11049	75	100				97	my $get_next = is_router($from) ? 'zone' : 'router';
11050	75	50				171	my $allowed = $navi->{ $from->{loop} }
11051							or internal_err("Loop $from->{loop}->{exit}->{name}$from->{loop}",
11052							" with empty navi");
11053	75					91	for my $interface (@$from_interfaces) {
11054	220	100				340	next if $interface->{main_interface};
11055	184					156	my $loop = $interface->{loop};
11056	184	100				270	next if not $loop;
11057	151	100				266	if (not $allowed->{$loop}) {
11058
11059							# debug("No: $loop->{exit}->{name}$loop");
11060	2					3	next;
11061							}
11062
11063							# Don't enter network which connects pair of virtual loopback
11064							# interfaces.
11065	149	50	33			248	next if $interface->{loopback} and $get_next eq 'zone';
11066	149					145	my $next = $interface->{$get_next};
11067
11068							# debug(" try: $from->{name} -> $interface->{name}");
11069	149	100				196	if (
11070							cluster_path_mark1(
11071							$next, $interface, $to, $end_intf,
11072							$path_tuples, $loop_leave, $navi
11073							)
11074							)
11075							{
11076	114					87	$success = 1;
11077	114					172	push @$loop_enter, $interface;
11078
11079							# debug(" enter: $from->{name} -> $interface->{name}");
11080							}
11081							}
11082
11083							# Don't store incomplete result.
11084	75	100				122	last BLOCK if not $success;
11085
11086							# Convert { intf->intf->node_type } to [ intf, intf, node_type ]
11087	73					78	my $tuples_aref = [];
11088	73					145	for my $in_intf_ref (keys %$path_tuples) {
11089	115	50				171	my $in_intf = $key2obj{$in_intf_ref}
11090							or internal_err("Unknown in_intf at tuple");
11091	115					105	my $hash = $path_tuples->{$in_intf_ref};
11092	115					162	for my $out_intf_ref (keys %$hash) {
11093	119	50				180	my $out_intf = $key2obj{$out_intf_ref}
11094							or internal_err("Unknown out_intf at tuple");
11095	119					113	my $at_router = $hash->{$out_intf_ref};
11096	119					344	push @$tuples_aref, [ $in_intf, $out_intf, $at_router ];
11097
11098							# debug("Tuple: $in_intf->{name}, $out_intf->{name} $at_router");
11099							}
11100							}
11101
11102							# Remove duplicates, which occur from nested loops..
11103	73					116	$loop_leave = [ unique(@$loop_leave) ];
11104
11105	73					137	$start_store->{loop_enter}->{$end_store} = $loop_enter;
11106	73					125	$start_store->{loop_leave}->{$end_store} = $loop_leave;
11107	73					111	$start_store->{path_tuples}->{$end_store} = $tuples_aref;
11108
11109							# Add data for reverse path.
11110	73					116	$end_store->{loop_enter}->{$start_store} = $loop_leave;
11111	73					110	$end_store->{loop_leave}->{$start_store} = $loop_enter;
11112	119					431	$end_store->{path_tuples}->{$start_store} =
11113	73 119					148 96	[ map { [ @{$_}[ 1, 0, 2 ] ] } @$tuples_aref ];
11114							}
11115
11116							# Restore temporarily changed path restrictions.
11117	197					223	for my $intf ($start_intf, $end_intf) {
11118	394	100				614	next if !$intf;
11119	85	100				141	next if !$intf->{saved_path_restrict};
11120	45					41	my $router = $intf->{router};
11121	45 45					37 56	for my $interface (@{ $router->{interfaces} }) {
11122	161	100				216	if (my $orig = delete $interface->{saved_path_restrict}) {
11123	48					79	$interface->{path_restrict} = $orig ;
11124							}
11125							else {
11126	113					148	delete $interface->{path_restrict};
11127							}
11128							}
11129							}
11130	197	100				286	if ($start_intf) {
11131	37	100				69	if (my $orig = delete $start_intf->{saved_reachable_at_zone}) {
11132	7					7	my $zone = $start_intf->{zone};
11133	7					15	$start_intf->{reachable_at}->{$zone} = $orig;
11134							}
11135							}
11136	197					187	for my $intf ($start_intf, $end_intf) {
11137	394	100				569	next if !$intf;
11138	85	100				149	if (my $interfaces = $intf->{redundancy_interfaces}) {
11139	25					25	for my $interface (@$interfaces) {
11140	50	100				103	next if $interface eq $intf;
11141	25 25					18 49	pop @{ $interface->{path_restrict} };
11142							}
11143							}
11144							}
11145
11146							# Disable pathrestriction at border of loop.
11147	197					197	for my $intf ($from_in, $to_out) {
11148	394	100	100			1212	if ( $intf
11149							and not $intf->{loop}
11150							and (my $restrictions = $intf->{path_restrict}))
11151							{
11152	11					11	for my $restrict (@$restrictions) {
11153	13					24	$restrict->{active_path} = 0;
11154							}
11155							}
11156							}
11157	197	100				296	if ($success) {
11158
11159							# When entering sub-graph at $from_in we will leave it at $to_out.
11160	195					314	$from_in->{path}->{$to_store} = $to_out;
11161							}
11162	197					572	return $success;
11163							}
11164
11165							# Mark path from $from to $to.
11166							# $from and $to are either a router or a zone.
11167							# For a path without loops, $from_store equals $from and $to_store equals $to.
11168							# If the path starts at an interface inside a cluster of loops
11169							# or at the border of a cluster,
11170							# and the interface has a pathrestriction attached,
11171							# then $from_store contains this interface.
11172							# If the path ends at an interface inside a loop or at the border of a loop,
11173							# $to_store contains this interface.
11174							# At each interface on the path from $from to $to,
11175							# we place a reference to the next interface on the path to $to_store.
11176							# This reference is found in a hash at attribute {path}.
11177							# Additionally we attach the path attribute to the src object.
11178							# Return value is true if a valid path was found.
11179							sub path_mark {
11180	519			519	0	540	my ($from, $to, $from_store, $to_store) = @_;
11181
11182							# debug("path_mark $from_store->{name} --> $to_store->{name}");
11183
11184	519					464	my $from_loop = $from->{loop};
11185	519					474	my $to_loop = $to->{loop};
11186
11187							# $from_store and $from differ if path starts at an interface
11188							# with pathrestriction.
11189							# Inside a loop, use $from_store, not $from,
11190							# because the path may differ depending on the start interface.
11191							# But outside a loop (pathrestriction is allowed at the border of a loop)
11192							# we have only a single path which enters the loop.
11193							# In this case we must not use the interface but the router,
11194							# otherwise we would get an invalid {path}:
11195							# $from_store->{path}->{$to_store} = $from_store;
11196	519	100				644	my $from_in = $from_store->{loop} ? $from_store : $from;
11197	519					399	my $to_out = undef;
11198	519					394	while (1) {
11199
11200							# debug("Dist: $from->{distance} $from->{name} ->Dist: $to->{distance} $to->{name}");
11201							# Paths meet outside a loop or at the edge of a loop.
11202	1356	100				2314	if ($from eq $to) {
11203
11204							# debug(" $from_in->{name} -> ".($to_out ? $to_out->{name}:''));
11205	326					464	$from_in->{path}->{$to_store} = $to_out;
11206	326					760	return 1;
11207							}
11208
11209							# Paths meet inside a loop.
11210	1030	100	75			2235	if ( $from_loop
11211							&& $to_loop
11212							&& $from_loop->{cluster_exit} eq $to_loop->{cluster_exit})
11213							{
11214	184					250	return cluster_path_mark($from, $to, $from_in, $to_out, $from_store,
11215							$to_store);
11216							}
11217
11218	846	100				1175	if ($from->{distance} >= $to->{distance}) {
11219
11220							# Mark has already been set for a sub-path.
11221	365	100				676	return 1 if $from_in->{path}->{$to_store};
11222	358					318	my $from_out = $from->{main};
11223	358	100				487	unless ($from_out) {
11224
11225							# Reached border of partition.
11226	7	50				18	return 0 if !$from_loop;
11227
11228							# $from_loop references object which is loop's exit.
11229	7					7	my $exit = $from_loop->{cluster_exit};
11230	7					7	$from_out = $exit->{main};
11231
11232							# Reached border of partition.
11233	7	50				11	return 0 if !$from_out;
11234
11235	7	50				11	cluster_path_mark($from, $exit, $from_in, $from_out,
11236							$from_store, $to_store)
11237							or return 0;
11238							}
11239
11240							# debug(" $from_in->{name} -> ".($from_out ? $from_out->{name}:''));
11241	358					529	$from_in->{path}->{$to_store} = $from_out;
11242	358					284	$from_in = $from_out;
11243	358					308	$from = $from_out->{main};
11244	358					425	$from_loop = $from->{loop};
11245							}
11246							else {
11247	481					405	my $to_in = $to->{main};
11248	481	100				670	unless ($to_in) {
11249
11250							# Reached border of partition.
11251	8	100				16	return 0 if !$to_loop;
11252
11253	6					8	my $entry = $to_loop->{cluster_exit};
11254	6					6	$to_in = $entry->{main};
11255
11256							# Reached border of partition.
11257	6	50				8	return 0 if !$to_in;
11258
11259	6	50				9	cluster_path_mark($entry, $to, $to_in, $to_out, $from_store,
11260							$to_store)
11261							or return 0;
11262							}
11263
11264							# debug(" $to_in->{name} -> ".($to_out ? $to_out->{name}:''));
11265	479					753	$to_in->{path}->{$to_store} = $to_out;
11266	479					359	$to_out = $to_in;
11267	479					406	$to = $to_in->{main};
11268	479					525	$to_loop = $to->{loop};
11269							}
11270							}
11271	0					0	return 0; # unused; only for perlcritic
11272							}
11273
11274							# Walk paths inside cyclic graph
11275							sub loop_path_walk {
11276	271			271	0	352	my ($in, $out, $loop_entry, $loop_exit, $call_at_zone, $rule, $fun) = @_;
11277
11278							# my $info = "loop_path_walk: ";
11279							# $info .= "$in->{name}->" if $in;
11280							# $info .= "$loop_entry->{name}=>$loop_exit->{name}";
11281							# $info .= "->$out->{name}" if $out;
11282							# debug($info);
11283
11284							# Process entry of cyclic graph.
11285	271	100	75			298	if (
11286							(
11287							is_router($loop_entry)
11288							or
11289
11290							# $loop_entry is interface with pathrestriction of original
11291							# loop_entry.
11292							is_interface($loop_entry)
11293							and
11294
11295							# Take only interface which originally was a router.
11296							$loop_entry->{router} eq
11297							$loop_entry->{loop_enter}->{$loop_exit}->[0]->{router}
11298							) xor $call_at_zone
11299							)
11300							{
11301
11302							# debug(" loop_enter");
11303	105 105					85 198	for my $out_intf (@{ $loop_entry->{loop_enter}->{$loop_exit} }) {
11304	155					200	$fun->($rule, $in, $out_intf);
11305							}
11306							}
11307
11308							# Process paths inside cyclic graph.
11309	271					445	my $path_tuples = $loop_entry->{path_tuples}->{$loop_exit};
11310
11311							# debug(" loop_tuples");
11312	271					305	for my $tuple (@$path_tuples) {
11313	406					403	my ($in_intf, $out_intf, $at_router) = @$tuple;
11314	406	100	100			1312	$fun->($rule, $in_intf, $out_intf)
11315							if $at_router xor $call_at_zone;
11316							}
11317
11318							# Process paths at exit of cyclic graph.
11319	271		67			340	my $exit_at_router =
11320							is_router($loop_exit)
11321							\|\| (is_interface($loop_exit)
11322							&& $loop_exit->{router} eq
11323							$loop_entry->{loop_leave}->{$loop_exit}->[0]->{router});
11324	271	100	100			804	if ($exit_at_router xor $call_at_zone) {
11325
11326							# debug(" loop_leave");
11327	165 165					125 307	for my $in_intf (@{ $loop_entry->{loop_leave}->{$loop_exit} }) {
11328	243					286	$fun->($rule, $in_intf, $out);
11329							}
11330							}
11331	271					466	return $exit_at_router;
11332							}
11333
11334							# Apply a function to a rule at every router or zone on the path from
11335							# src to dst of the rule.
11336							# $where tells, where the function gets called: at 'Router' or 'Zone'.
11337							# Default is 'Router'.
11338							sub path_walk {
11339	1467			1467	0	1452	my ($rule, $fun, $where) = @_;
11340	1467	50				2096	internal_err("undefined rule") unless $rule;
11341	1467					1285	my $src = $rule->{src};
11342	1467					1211	my $dst = $rule->{dst};
11343
11344	1467		67			3091	my $from_store = $obj2path{$src} \|\| get_path $src;
11345	1467		67			2857	my $to_store = $obj2path{$dst} \|\| get_path $dst;
11346	1467		67			3466	my $from = $from_store->{router} \|\| $from_store;
11347	1467		67			3168	my $to = $to_store->{router} \|\| $to_store;
11348	1467	100				1788	my $path_store = $from_store->{loop} ? $from_store : $from;
11349
11350							# debug(print_rule $rule);
11351							# debug(" start: $from->{name}, $to->{name}" . ($where?", at $where":''));
11352							# my $fun2 = $fun;
11353							# $fun = sub {
11354							# my($rule, $in, $out) = @_;
11355							# my $in_name = $in?$in->{name}:'-';
11356							# my $out_name = $out?$out->{name}:'-';
11357							# debug(" Walk: $in_name, $out_name");
11358							# $fun2->(@_);
11359							# };
11360	1467	50	33			4090	$from and $to or internal_err(print_rule $rule);
11361	1467	50				2626	$from eq $to and internal_err("Unenforceable:\n ", print_rule $rule);
11362
11363	1467	100				2753	if (!$path_store->{path}->{$to_store}) {
11364	495	100				704	if (!path_mark($from, $to, $from_store, $to_store)) {
11365	4					13	err_msg("No valid path\n",
11366							" from $from_store->{name}\n",
11367							" to $to_store->{name}\n",
11368							" for rule ", print_rule($rule), "\n",
11369							" Check path restrictions and crypto interfaces.");
11370	4					10	delete $path_store->{path}->{$to_store};
11371	4					12	return;
11372							}
11373							}
11374	1463					1170	my $in = undef;
11375	1463					1054	my $out;
11376	1463		100			3018	my $at_zone = $where && $where eq 'Zone';
11377	1463		75			1730	my $call_it = (is_router($from) xor $at_zone);
11378
11379							# Path starts inside a cyclic graph
11380							# or at interface of router inside cyclic graph.
11381	1463	100	50			3919	if ($from->{loop}
11382							and $from_store->{loop_exit}
11383							and my $loop_exit = $from_store->{loop_exit}->{$to_store})
11384							{
11385	201					259	my $loop_out = $path_store->{path}->{$to_store};
11386	201					239	my $exit_at_router =
11387							loop_path_walk($in, $loop_out, $from_store, $loop_exit, $at_zone,
11388							$rule, $fun);
11389	201	100				302	if (not $loop_out) {
11390
11391							# debug("exit: path_walk: dst in loop");
11392	143					343	return;
11393							}
11394
11395							# Continue behind loop.
11396	58		75			151	$call_it = not($exit_at_router xor $at_zone);
11397	58					46	$in = $loop_out;
11398	58					102	$out = $in->{path}->{$to_store};
11399							}
11400							else {
11401	1262					1882	$out = $path_store->{path}->{$to_store};
11402							}
11403	1320					977	while (1) {
11404	4411	100	100			12403	if ( $in
11405							and $in->{loop_entry}
11406							and my $loop_entry = $in->{loop_entry}->{$to_store})
11407							{
11408	70					92	my $loop_exit = $loop_entry->{loop_exit}->{$to_store};
11409	70					83	my $loop_out = $in->{path}->{$to_store};
11410	70					88	my $exit_at_router =
11411							loop_path_walk($in, $loop_out, $loop_entry, $loop_exit,
11412							$at_zone, $rule, $fun);
11413	70	100				95	if (not $loop_out) {
11414
11415							# debug("exit: path_walk: reached dst in loop");
11416	52					126	return;
11417							}
11418	18		50			50	$call_it = not($exit_at_router xor $at_zone);
11419	18					15	$in = $loop_out;
11420	18					34	$out = $in->{path}->{$to_store};
11421							}
11422							else {
11423	4341	100				5567	if ($call_it) {
11424	1858					2290	$fun->($rule, $in, $out);
11425							}
11426
11427							# End of path has been reached.
11428	4341	100				5602	if (not $out) {
11429
11430							# debug("exit: path_walk: reached dst");
11431	1268					2871	return;
11432							}
11433	3073					2736	$call_it = !$call_it;
11434	3073					2266	$in = $out;
11435	3073					4418	$out = $in->{path}->{$to_store};
11436							}
11437							}
11438	0					0	return;
11439							}
11440
11441							my %border2obj2auto;
11442
11443							sub set_auto_intf_from_border {
11444	10			10	0	11	my ($border) = @_;
11445	10					7	my %active_path;
11446							my $reach_from_border;
11447							$reach_from_border = sub {
11448	74			74		67	my ($network, $in_intf, $result) = @_;
11449	74					86	$active_path{$network} = 1;
11450	74					123	$result->{$network}->{$in_intf} = $in_intf;
11451							# debug "$network->{name}: $in_intf->{name}";
11452	74 74					47 92	for my $interface (@{ $network->{interfaces} }) {
11453	153	100				282	next if $interface eq $in_intf;
11454	79	100				101	next if $interface->{zone};
11455	73	100				110	next if $interface->{orig_main};
11456	61					43	my $router = $interface->{router};
11457	61	100				115	next if $active_path{$router};
11458	39					43	$active_path{$router} = 1;
11459	39					62	$result->{$router}->{$interface} = $interface;
11460							# debug "$router->{name}: $interface->{name}";
11461
11462	39 39					27 62	for my $out_intf (@{ $router->{interfaces} }) {
11463	115	100				202	next if $out_intf eq $interface;
11464	76	100				99	next if $out_intf->{orig_main};
11465	64					60	my $out_net = $out_intf->{network};
11466	64					81	$reach_from_border->($out_net, $out_intf, $result);
11467							}
11468	39					68	$active_path{$router} = 0;
11469							}
11470	74					141	$active_path{$network} = 0;
11471	10					37	};
11472	10					14	my $result = {};
11473	10					14	$reach_from_border->($border->{network}, $border, $result);
11474	10					20	for my $href (values %$result) {
11475	42					90	$href = [ values %$href ];
11476							}
11477	10					17	$border2obj2auto{$border} = $result;
11478	10					16	return;
11479							}
11480
11481							# $src is an auto_interface, interface or router.
11482							# Result is the set of interfaces of $src located at the front side
11483							# of the direction to $dst.
11484							sub path_auto_interfaces {
11485	55			55	0	55	my ($src, $dst) = @_;
11486	55					37	my @result;
11487	52					74	my ($src2, $managed) =
11488							is_autointerface($src)
11489	55	100				66	? @{$src}{ 'object', 'managed' }
11490							: ($src, undef);
11491	55	100				70	my $dst2 = is_autointerface($dst) ? $dst->{object} : $dst;
11492
11493	55		67			153	my $from_store = $obj2path{$src2} \|\| get_path $src2;
11494	55		67			125	my $to_store = $obj2path{$dst2} \|\| get_path $dst2;
11495	55		33			149	my $from = $from_store->{router} \|\| $from_store;
11496	55		33			131	my $to = $to_store->{router} \|\| $to_store;
11497
11498	55	100				105	$from eq $to and return ();
11499	53	100				106	if (!$from_store->{path}->{$to_store}) {
11500	24	50				37	if (!path_mark($from, $to, $from_store, $to_store)) {
11501	0					0	err_msg("No valid path\n",
11502							" from $from_store->{name}\n",
11503							" to $to_store->{name}\n",
11504							" while resolving $src->{name}",
11505							" (destination is $dst->{name}).\n",
11506							" Check path restrictions and crypto interfaces.");
11507	0					0	delete $from_store->{path}->{$to_store};
11508	0					0	return;
11509							}
11510							}
11511	53	100	67			122	if ($from_store->{loop_exit}
11512							and my $exit = $from_store->{loop_exit}->{$to_store})
11513							{
11514	9 9					7 22	@result = @{ $from->{loop_enter}->{$exit} };
11515							}
11516							else {
11517	44					76	@result = ($from_store->{path}->{$to_store});
11518							}
11519	53 62					53 129	@result = grep { $_->{ip} ne 'tunnel' } @result;
11520
11521							# Find auto interface inside zone.
11522							# $src is located inside some zone.
11523							# $src2 is known to be unmanaged router or network.
11524	53	100				68	if (!is_router($from)) {
11525	34					26	my %result;
11526	34					36	for my $border (@result) {
11527	40	100				78	if (not $border2obj2auto{$border}) {
11528	10					14	set_auto_intf_from_border($border);
11529							}
11530	40					60	my $auto_intf = $border2obj2auto{$border}->{$src2};
11531	40					41	for my $interface (@$auto_intf) {
11532	60					128	$result{$interface} = $interface;
11533							}
11534							}
11535	34					84	@result = sort by_name values %result;
11536							}
11537
11538	53					50	my $bridged_count = 0;
11539	53					54	for my $interface (@result) {
11540
11541							# If device has virtual interface, main and virtual interface
11542							# are swapped. Swap it back here because we need the
11543							# original main interface if an interface is used in a rule.
11544	80	50 100				218	if (my $orig = $interface->{orig_main}) {
11545	0					0	$interface = $orig;
11546							}
11547
11548							# Change bridge interface to layer3 interface.
11549							# Prevent duplicate layer3 interface.
11550							elsif (my $layer3_intf = $interface->{layer3_interface}) {
11551	2					2	$interface = $layer3_intf;
11552	2					3	$bridged_count++;
11553							}
11554							}
11555	53	50				84	if ($bridged_count > 1) {
11556	0					0	@result = unique(@result);
11557							}
11558
11559							# debug("$src2->{name}.[auto] = ", join ',', map {$_->{name}} @result);
11560	53 0	50				144 0	return($managed ? grep { $_->{router}->{managed} } @result : @result);
11561							}
11562
11563							########################################################################
11564							# Handling of crypto tunnels.
11565							########################################################################
11566
11567							sub link_ipsec {
11568	337			337	0	591	for my $ipsec (values %ipsec) {
11569
11570							# Convert name of ISAKMP definition to object with ISAKMP definition.
11571	20 20					19 34	my ($type, $name) = @{ $ipsec->{key_exchange} };
11572	20	50				33	if ($type eq 'isakmp') {
11573	20	50				43	my $isakmp = $isakmp{$name}
11574							or err_msg "Can't resolve reference to $type:$name",
11575							" for $ipsec->{name}";
11576	20					50	$ipsec->{key_exchange} = $isakmp;
11577							}
11578							else {
11579	0					0	err_msg("Unknown key_exchange type '$type' for $ipsec->{name}");
11580							}
11581							}
11582	337					313	return;
11583							}
11584
11585							sub link_crypto {
11586	337			337	0	682	for my $crypto (values %crypto) {
11587	21					22	my $name = $crypto->{name};
11588
11589							# Convert name of IPSec definition to object with IPSec definition.
11590	21 21					18 32	my ($type, $name2) = @{ $crypto->{type} };
11591
11592	21	50				28	if ($type eq 'ipsec') {
11593	21	50				45	my $ipsec = $ipsec{$name2}
11594							or err_msg "Can't resolve reference to $type:$name2",
11595							" for $name";
11596	21					36	$crypto->{type} = $ipsec;
11597							}
11598							else {
11599	0					0	err_msg("Unknown type '$type' for $name");
11600							}
11601							}
11602	337					298	return;
11603							}
11604
11605							# Generate rules to permit crypto traffic between tunnel endpoints.
11606							sub gen_tunnel_rules {
11607	27			27	0	25	my ($intf1, $intf2, $ipsec) = @_;
11608	27					23	my $use_ah = $ipsec->{ah};
11609	27		33			48	my $use_esp = $ipsec->{esp_authentication} \|\| $ipsec->{esp_encryption};
11610	27					28	my $nat_traversal = $ipsec->{key_exchange}->{nat_traversal};
11611	27					24	my @rules;
11612	27					42	my $rule = { src => $intf1, dst => $intf2 };
11613	27	50	67			76	if (not $nat_traversal or $nat_traversal ne 'on') {
11614	27	50				33	$use_ah
11615							and push @rules, { %$rule, prt => $prt_ah };
11616	27	50				87	$use_esp
11617							and push @rules, { %$rule, prt => $prt_esp };
11618	27					71	push @rules,
11619							{
11620							%$rule,
11621							src_range => $prt_ike->{src_range},
11622							prt => $prt_ike->{dst_range}
11623							};
11624							}
11625	27	100				45	if ($nat_traversal) {
11626	15					32	push @rules,
11627							{
11628							%$rule,
11629							src_range => $prt_natt->{src_range},
11630							prt => $prt_natt->{dst_range}
11631							};
11632							}
11633	27					62	return \@rules;
11634							}
11635
11636							# Link tunnel networks with tunnel hubs.
11637							# ToDo: Are tunnels between different private contexts allowed?
11638							sub link_tunnels {
11639
11640	337			337	0	305	my %hub_seen;
11641
11642							# Collect clear-text interfaces of all tunnels.
11643							my @real_interfaces;
11644
11645	337					774	for my $crypto (sort by_name values %crypto) {
11646	21					24	my $name = $crypto->{name};
11647	21					22	my $private = $crypto->{private};
11648	21					29	my $real_hubs = delete $crypto2hubs{$name};
11649	21					32	my $real_spokes = delete $crypto2spokes{$name};
11650	21 21					29 49	$real_hubs = [ grep { !$_->{disabled} } @$real_hubs ];
11651	21 25					24 44	$real_spokes = [ grep { !$_->{disabled} } @$real_spokes ];
11652	21	50	33			79	$real_hubs and @$real_hubs
11653							or warn_msg("No hubs have been defined for $name");
11654
11655	21	50	33			64	$real_spokes and @$real_spokes
11656							or warn_msg("No spokes have been defined for $name");
11657
11658	21					25	my $isakmp = $crypto->{type}->{key_exchange};
11659	21					34	my $need_id = $isakmp->{authentication} eq 'rsasig';
11660	21					24	for my $real_hub (@$real_hubs) {
11661
11662							# Substitute crypto name by crypto object.
11663	21 21					13 32	for my $crypto_name (@{ $real_hub->{hub} }) {
11664	27	100				63	$crypto_name eq $name and $crypto_name = $crypto;
11665							}
11666
11667							# Collect managed routers with crypto hub.
11668							# Note: Crypto routers are splitted internally into
11669							# two nodes. Typically we get get a node with only
11670							# a single crypto interface.
11671	21					22	my $router = $real_hub->{router};
11672	21	50				32	$router->{managed} or next;
11673
11674							# Router of type {do_auth} can only check certificates,
11675							# not pre-shared keys.
11676	21	50	67			59	$router->{model}->{do_auth} and not $need_id and
11677							err_msg("$router->{name} needs authentication=rsasig",
11678							" in $isakmp->{name}");
11679
11680							# Take original router with cleartext interface(s).
11681	21	100				32	if (my $orig_router = $router->{orig_router}) {
11682	18					19	$router = $orig_router;
11683							}
11684	21	100				77	push @managed_crypto_hubs, $router if not $hub_seen{$router}++;
11685							}
11686	21					22	push @real_interfaces, @$real_hubs;
11687
11688							# Generate a single tunnel from each spoke to a single hub.
11689							# If there are multiple hubs, they are assumed to form
11690							# a high availability cluster. In this case a single tunnel is created
11691							# with all hubs as possible endpoints. Traffic between hubs is
11692							# prevented by automatically added pathrestrictions.
11693	21					24	for my $spoke_net (@$real_spokes) {
11694	25					90	(my $net_name = $spoke_net->{name}) =~ s/network://;
11695	25 25					27 41	push @{ $crypto->{tunnels} }, $spoke_net;
11696	25					30	my $spoke = $spoke_net->{interfaces}->[0];
11697	25					27	$spoke->{crypto} = $crypto;
11698	25					21	my $real_spoke = $spoke->{real_interface};
11699	25					25	$real_spoke->{spoke} = $crypto;
11700
11701							# Each spoke gets a fresh hub interface.
11702	25					20	my @hubs;
11703	25					32	for my $real_hub (@$real_hubs) {
11704	25					24	my $router = $real_hub->{router};
11705	25	100				40	if (my $orig_router = $router->{orig_router}) {
11706	22					19	$router = $orig_router;
11707							}
11708	25					25	my $hardware = $real_hub->{hardware};
11709	25					142	(my $intf_name = $real_hub->{name}) =~ s/\..*$/.$net_name/;
11710	25					47	my $hub = new(
11711							'Interface',
11712							name => $intf_name,
11713							ip => 'tunnel',
11714							crypto => $crypto,
11715
11716							# Attention: shared hardware between router and
11717							# orig_router.
11718							hardware => $hardware,
11719							is_hub => 1,
11720							real_interface => $real_hub,
11721							router => $router,
11722							network => $spoke_net
11723							);
11724	25	50				48	$hub->{bind_nat} = $real_hub->{bind_nat}
11725							if $real_hub->{bind_nat};
11726	25 25					21 30	push @{ $router->{interfaces} }, $hub;
11727	25 25					27 25	push @{ $hardware->{interfaces} }, $hub;
11728	25 25					18 24	push @{ $spoke_net->{interfaces} }, $hub;
11729	25 25					20 38	push @{ $hub->{peers} }, $spoke;
11730	25 25					18 37	push @{ $spoke->{peers} }, $hub;
11731	25					29	push @hubs, $hub;
11732
11733							# We need hub also be available in orig_interfaces.
11734	25	100				45	if (my $aref = $router->{orig_interfaces}) {
11735	22					24	push @$aref, $hub;
11736							}
11737
11738	25	100				108	if ($real_spoke->{ip} =~ /^(?:negotiated\|short\|unnumbered)$/) {
11739	10					9	my $model = $router->{model};
11740	10	50	67			27	if (not ( $model->{do_auth} or $model->{can_dyn_crypto})) {
11741	0					0	err_msg "$router->{name} can't establish crypto",
11742							" tunnel to $real_spoke->{name} with unknown IP";
11743							}
11744							}
11745
11746	25	50				35	if ($private) {
11747	0					0	my $s_p = $real_spoke->{private};
11748	0					0	my $h_p = $real_hub->{private};
11749	0	0	0			0	$s_p and $s_p eq $private
11750							or $h_p and $h_p eq $private
11751							or err_msg
11752							"Tunnel $real_spoke->{name} to $real_hub->{name}",
11753							" of $private.private $name",
11754							" must reference at least one object",
11755							" out of $private.private";
11756							}
11757							else {
11758	25	50				39	$real_spoke->{private}
11759							and err_msg "Tunnel of public $name must not",
11760							" reference $real_spoke->{name} of",
11761							" $real_spoke->{private}.private";
11762	25	50				78	$real_hub->{private}
11763							and err_msg "Tunnel of public $name must not",
11764							" reference $real_hub->{name} of",
11765							" $real_hub->{private}.private";
11766							}
11767							}
11768
11769	25					32	my $router = $spoke->{router};
11770	25					16	my @other;
11771							my $has_id_hosts;
11772	25 25					21 31	for my $interface (@{ $router->{interfaces} }) {
11773	56					50	my $network = $interface->{network};
11774	56	100 100				119	if ($network->{has_id_hosts}) {
11775	12					11	$has_id_hosts = $network;
11776							}
11777							elsif ($interface->{ip} ne 'tunnel')
11778							{
11779	19					23	push @other, $interface;
11780							}
11781							}
11782	25	50	67			68	if ($has_id_hosts and @other) {
11783	0					0	err_msg "Must not use $has_id_hosts->{name} with ID hosts",
11784							" together with networks having no ID host: ",
11785	0					0	join(',', map { $_->{name} } @other);
11786							}
11787	25					20	push @real_interfaces, $real_spoke;
11788
11789	25	50	67			52	if ($router->{managed} && $crypto->{detailed_crypto_acl}) {
11790	0					0	err_msg(
11791							"Attribute 'detailed_crypto_acl' is not",
11792							" allowed for managed spoke $router->{name}"
11793							);
11794							}
11795
11796							# Automatically add pathrestriction between interfaces
11797							# of redundant hubs.
11798	25	50				86	if (@hubs > 1) {
11799	0					0	my $name2 = "auto-restriction:$crypto->{name}";
11800	0					0	add_pathrestriction($name, \@hubs);
11801							}
11802							}
11803							}
11804
11805							# Check for undefined crypto references.
11806	337					550	for my $crypto (keys %crypto2hubs) {
11807	0 0					0 0	for my $interface (@{ $crypto2hubs{$crypto} }) {
11808	0					0	err_msg("$interface->{name} references unknown $crypto");
11809							}
11810							}
11811	337					521	for my $crypto (keys %crypto2spokes) {
11812	0 0					0 0	for my $network (@{ $crypto2spokes{$crypto} }) {
11813	0					0	err_msg "$network->{interfaces}->[0]->{name}",
11814							" references unknown $crypto";
11815							}
11816							}
11817	337					430	return;
11818							}
11819
11820							# Needed for crypto_rules,
11821							# for default route optimization,
11822							# while generating chains of iptables and
11823							# for local optimization.
11824							my $network_00 = new(
11825							'Network',
11826							name => "network:0/0",
11827							ip => 0,
11828							mask => 0,
11829							is_aggregate => 1,
11830							is_supernet => 1
11831							);
11832
11833							sub crypto_behind {
11834	28			28	0	26	my ($interface, $managed) = @_;
11835	28	100				35	if ($managed) {
11836	4					3	my $zone = $interface->{zone};
11837	4 4	50				4 9	1 == @{ $zone->{interfaces} }
11838							or err_msg "Exactly one security zone must be located behind",
11839							" managed crypto $interface->{name}";
11840	4					5	my $zone_networks = $zone->{networks};
11841	4					6	return @$zone_networks;
11842							}
11843							else {
11844	24					23	my $network = $interface->{network};
11845	24 24	50				17 41	1 == @{ $network->{interfaces} }
11846							or err_msg "Exactly one network must be located behind",
11847							" unmanaged crypto $interface->{name}";
11848	24					43	return($network);
11849							}
11850							}
11851
11852							# Valid group-policy attributes.
11853							# Hash describes usage:
11854							# - tg_general: attribute is only applicable to 'tunnel-group general-attributes'
11855							my %asa_vpn_attributes = (
11856
11857							# group-policy attributes
11858							banner => {},
11859							'check-subject-name' => {},
11860							'dns-server' => {},
11861							'default-domain' => {},
11862							'split-dns' => {},
11863							'trust-point' => {},
11864							'wins-server' => {},
11865							'vpn-access-hours' => {},
11866							'vpn-idle-timeout' => {},
11867							'vpn-session-timeout' => {},
11868							'vpn-simultaneous-logins' => {},
11869							vlan => {},
11870							'split-tunnel-policy' => {},
11871							'authentication-server-group' => { tg_general => 1 },
11872							'authorization-server-group' => { tg_general => 1 },
11873							'authorization-required' => { tg_general => 1 },
11874							'username-from-certificate' => { tg_general => 1 },
11875							);
11876
11877							sub verify_asa_vpn_attributes {
11878	38			38	0	31	my ($obj) = @_;
11879	38	50				62	my $attributes = $obj->{radius_attributes} or return;
11880	38					83	for my $key (sort keys %$attributes) {
11881	32					43	my $spec = $asa_vpn_attributes{$key};
11882	32	50				42	$spec or err_msg("Invalid radius_attribute '$key' at $obj->{name}");
11883	32	100 100				74	if ($key eq 'split-tunnel-policy') {
11884	3					6	my $value = $attributes->{$key};
11885	3	50				21	$value =~ /^(?:tunnelall\|tunnelspecified)$/
11886							or err_msg("Unsupported value in radius_attributes",
11887							" of $obj->{name}\n",
11888							" '$key = $value'");
11889							}
11890							elsif ($key eq 'trust-point') {
11891	14	100 100				24	if (is_host($obj)) {
11892	3	50				9	$obj->{range} or
11893							err_msg("Must not use radius_attribute '$key'",
11894							" at $obj->{name}");
11895							}
11896							elsif (is_network($obj)) {
11897	3 6 3	50				3 13 5	grep { $_->{ip} } @{ $obj->{hosts} } and
11898							err_msg("Must not use radius_attribute '$key'",
11899							" at $obj->{name}");
11900							}
11901							}
11902							}
11903	38					43	return;
11904							}
11905
11906							# Host with ID that doesn't contain a '@' must use attribute 'verify-subject-name'.
11907							sub verify_subject_name {
11908	18			18	0	16	my ($host, $peers) = @_;
11909	18					22	my $id = $host->{id};
11910	18	100				60	return if $id =~ /@/;
11911							my $has_attr = sub {
11912	3			3		4	my ($obj) = @_;
11913	3					5	my $attributes = $obj->{radius_attributes};
11914	3		33			24	return ($attributes && $attributes->{'check-subject-name'});
11915	3					10	};
11916	3	50				5	return if $has_attr->($host);
11917	0	0				0	return if $has_attr->($host->{network});
11918	0					0	my $missing;
11919	0					0	for my $peer (@$peers) {
11920	0	0				0	next if $has_attr->($peer->{router});
11921	0					0	$missing = 1;
11922							}
11923	0	0				0	if ($missing) {
11924	0					0	err_msg("Missing radius_attribute 'check-subject-name'\n",
11925							" for $host->{name}");
11926							}
11927	0					0	return;
11928							}
11929
11930							sub verify_asa_trustpoint {
11931	11			11	0	11	my ($router, $crypto) = @_;
11932	11					13	my $isakmp = $crypto->{type}->{key_exchange};
11933	11	100				19	if ($isakmp->{authentication} eq 'rsasig') {
11934	9	100				18	$isakmp->{trust_point} or
11935							err_msg("Missing attribute 'trust_point' in",
11936							" $isakmp->{name} for $router->{name}");
11937							}
11938	11					22	return;
11939							}
11940
11941							sub expand_crypto {
11942	239			239	0	309	progress('Expanding crypto rules');
11943
11944	239					191	my %id2interface;
11945
11946	239					423	for my $crypto (values %crypto) {
11947	20					23	my $name = $crypto->{name};
11948	20					25	my $isakmp = $crypto->{type}->{key_exchange};
11949	20					26	my $need_id = $isakmp->{authentication} eq 'rsasig';
11950
11951							# Do consistency checks and
11952							# add rules which allow encrypted traffic.
11953	20 20					16 29	for my $tunnel (@{ $crypto->{tunnels} }) {
11954	22	50				37	next if $tunnel->{disabled};
11955	22 22					15 28	for my $tunnel_intf (@{ $tunnel->{interfaces} }) {
11956	44	100				107	next if $tunnel_intf->{is_hub};
11957	22					21	my $router = $tunnel_intf->{router};
11958	22					19	my $peers = $tunnel_intf->{peers};
11959	22					19	my $managed = $router->{managed};
11960	22					27	my @encrypted;
11961							my $has_id_hosts;
11962	0					0	my $has_other_network;
11963	0					0	my @verify_radius_attributes;
11964	22 22					17 27	for my $interface (@{ $router->{interfaces} }) {
11965	50	100				125	next if $interface eq $tunnel_intf;
11966	28	50				43	if ($interface->{ip} eq 'tunnel') {
11967	0	0	0			0	if ($managed && $router->{model}->{crypto} eq 'EZVPN') {
11968	0					0	err_msg "Exactly 1 crypto tunnel expected",
11969							" for $router->{name} with EZVPN";
11970							}
11971	0					0	next;
11972							}
11973	28	50				44	if ($interface->{spoke}) {
11974	0	0				0	if (my $id = $interface->{id}) {
11975	0	0				0	if (my $intf2 = $id2interface{$id}) {
11976	0					0	err_msg "Same ID '$id' is used at",
11977							" $interface->{name} and $intf2->{name}";
11978							}
11979	0					0	$id2interface{$id} = $interface;
11980							}
11981	0					0	next;
11982							}
11983	28					27	my $network = $interface->{network};
11984	28					36	my @all_networks = crypto_behind($interface, $managed);
11985	28	100				35	if ($network->{has_id_hosts}) {
11986	12					11	$has_id_hosts = 1;
11987	12	50				18	$managed
11988							and err_msg
11989							"$network->{name} having ID hosts must not",
11990							" be located behind managed $router->{name}";
11991	12					12	push @verify_radius_attributes, $network;
11992
11993							# Must not have multiple networks.
11994	12	50				20	@all_networks > 1 and internal_err();
11995
11996							# Rules for single software clients are stored
11997							# individually at crypto hub interface.
11998	12 12					12 14	for my $host (@{ $network->{hosts} }) {
11999	18					19	my $id = $host->{id};
12000
12001							# ID host has already been checked to have
12002							# exacly one subnet.
12003	18					18	my $subnet = $host->{subnets}->[0];
12004	18					15	push @verify_radius_attributes, $host;
12005	18					19	for my $peer (@$peers) {
12006	18					14	my $no_nat_set = $peer->{no_nat_set};
12007	18	100				38	if (my $other = $peer->{id_rules}->{$id}) {
12008	1					2	my $src = $other->{src};
12009	1					12	err_msg("Duplicate ID-host $id from",
12010							" $src->{network}->{name} and",
12011							" $subnet->{network}->{name}",
12012							" at $peer->{router}->{name}");
12013	1					3	next;
12014							}
12015	17					105	$peer->{id_rules}->{$id} = {
12016							name => "$peer->{name}.$id",
12017							ip => 'tunnel',
12018							src => $subnet,
12019							no_nat_set => $no_nat_set,
12020
12021							# Needed during local_optimization.
12022							router => $peer->{router},
12023							};
12024							}
12025							}
12026	12					21	push @encrypted, $network;
12027							}
12028							else {
12029	16					16	$has_other_network = 1;
12030	16					25	push @encrypted, @all_networks;
12031							}
12032							}
12033							$has_id_hosts
12034	0					0	and $has_other_network
12035							and err_msg(
12036							"Must not use host with ID and network",
12037							" together at $tunnel_intf->{name}: ",
12038	22	50	67			56	join(', ', map { $_->{name} } @encrypted)
12039							);
12040	0					0	$has_id_hosts
12041							or $has_other_network
12042							or err_msg(
12043							"Must use network or host with ID",
12044							" at $tunnel_intf->{name}: ",
12045	22	50	67			56	join(', ', map { $_->{name} } @encrypted)
12046							);
12047
12048	22					22	my $real_spoke = $tunnel_intf->{real_interface};
12049	22					22	for my $peer (@$peers) {
12050	22					28	$peer->{peer_networks} = \@encrypted;
12051	22					20	my $router = $peer->{router};
12052	22					24	my $do_auth = $router->{model}->{do_auth};
12053	22					50	my $unknown_ip =
12054							$real_spoke->{ip} =~
12055							/^(?:negotiated\|short\|unnumbered)$/;
12056	22	100 100 100				48	if ($tunnel_intf->{id}) {
12057	9	50				20	$need_id or
12058							err_msg("Invalid attribute 'id' at",
12059							" $tunnel_intf->{name}.\n",
12060							" Set authentication=rsasig at",
12061							" $isakmp->{name}");
12062							}
12063							elsif ($encrypted[0]->{has_id_hosts}) {
12064	10	50				25	$do_auth
12065							or err_msg("$router->{name} can't check IDs",
12066							" of $encrypted[0]->{name}");
12067							}
12068							elsif ($need_id) {
12069	1					5	err_msg("$tunnel_intf->{name}",
12070							" needs attribute 'id',",
12071							" because $isakmp->{name}",
12072							" has authentication=rsasig");
12073							}
12074							}
12075
12076	22 22	100				32 61	if (grep({ $_->{router}->{model}->{crypto} eq 'ASA_VPN' }
12077							@$peers))
12078							{
12079	11					20	for my $obj (@verify_radius_attributes) {
12080	30					38	verify_asa_vpn_attributes($obj);
12081	30	100				34	if (is_host($obj)) {
12082	18					21	verify_subject_name($obj, $peers);
12083							}
12084							}
12085							}
12086
12087	22	50	67			52	if ($managed && $router->{model}->{crypto} eq 'ASA') {
12088	0					0	verify_asa_trustpoint($router, $crypto);
12089							}
12090
12091							# Add rules to permit crypto traffic between
12092							# tunnel endpoints.
12093							# If one tunnel endpoint has no known IP address,
12094							# some rules have to be added manually.
12095	22	100	67			105	if ( $real_spoke
12096							and $real_spoke->{ip} !~ /^(?:short\|unnumbered)$/)
12097							{
12098	15 15					13 18	for my $hub (@{ $tunnel_intf->{peers} }) {
12099	15					15	my $real_hub = $hub->{real_interface};
12100	15					30	for my $pair (
12101							[ $real_spoke, $real_hub ],
12102							[ $real_hub, $real_spoke ]
12103							)
12104							{
12105	30					27	my ($intf1, $intf2) = @$pair;
12106
12107							# Don't generate incoming ACL from unknown
12108							# address.
12109	30	100				50	next if $intf1->{ip} eq 'negotiated';
12110	27					43	my $rules_ref =
12111							gen_tunnel_rules($intf1, $intf2,
12112							$crypto->{type});
12113	27 27					20 42	push @{ $expanded_rules{permit} }, @$rules_ref;
12114	27					36	add_rules $rules_ref;
12115							}
12116							}
12117							}
12118							}
12119							}
12120							}
12121
12122							# Check for duplicate IDs of different hosts
12123							# coming into different hardware at current device.
12124							# ASA_VPN can't distinguish different hosts with same ID
12125							# coming into different hardware interfaces.
12126	239					332	for my $router (@managed_crypto_hubs) {
12127	16					18	my $model = $router->{model};
12128	16	50				30	my $crypto = $model->{crypto} or next;
12129	16	100				35	$crypto eq 'ASA_VPN' or next;
12130	19					27	my @id_rules_interfaces =
12131	8 8					8 11	grep { $_->{id_rules} } @{ $router->{interfaces} };
12132	8	100				19	@id_rules_interfaces >= 2 or next;
12133	3					3	my %id2src;
12134	3					6	for my $interface (@id_rules_interfaces) {
12135	6					7	my $hash = $interface->{id_rules};
12136	6					10	for my $id (keys %$hash) {
12137	10					13	my $src1 = $hash->{$id}->{src};
12138	10	100				16	if (my $src2 = $id2src{$id}) {
12139	1					6	err_msg("Duplicate ID-host $id from",
12140							" $src1->{network}->{name} and",
12141							" $src2->{network}->{name}",
12142							" at $router->{name}");
12143							}
12144							else {
12145	9					21	$id2src{$id} = $src1;
12146							}
12147							}
12148							}
12149							}
12150
12151	239					619	for my $router (@managed_crypto_hubs) {
12152	16					20	my $crypto_type = $router->{model}->{crypto};
12153	16	100 50				31	if ($crypto_type eq 'ASA_VPN') {
12154	8					12	verify_asa_vpn_attributes($router);
12155
12156							# Move 'trust-point' from radius_attributes to router attribute.
12157	8	50				19	my $trust_point =
12158							delete $router->{radius_attributes}->{'trust-point'}
12159							or err_msg("Missing 'trust-point' in radius_attributes",
12160							" of $router->{name}");
12161	8					18	$router->{trust_point} = $trust_point;
12162							}
12163							elsif($crypto_type eq 'ASA') {
12164	8 8					7 9	for my $interface (@{ $router->{interfaces} }) {
12165	19	100				34	my $crypto = $interface->{crypto} or next;
12166	11					15	verify_asa_trustpoint($router, $crypto);
12167							}
12168							}
12169							}
12170
12171							# Hash only needed during expand_group and expand_rules.
12172	239					280	%auto_interfaces = ();
12173	239					244	return;
12174							}
12175
12176							# Hash for converting a reference of an object back to this object.
12177							my %ref2obj;
12178
12179							sub setup_ref2obj {
12180	226			226	0	272	for my $network (@networks) {
12181	938					1275	$ref2obj{$network} = $network;
12182	938 938 938					706 1082 1127	for my $obj (@{ $network->{subnets} }, @{ $network->{interfaces} }) {
12183	1332					2536	$ref2obj{$obj} = $obj;
12184							}
12185							}
12186	226					220	return;
12187							}
12188
12189							##############################################################################
12190							# Check if high-level and low-level semantics of rules with an supernet
12191							# as source or destination are equivalent.
12192							#
12193							# I. Typically, we only use incoming ACLs.
12194							# (A) rule "permit any:X dst"
12195							# high-level: any:X in zone X get access to dst
12196							# low-level: like above, but additionally, the networks matching any:X
12197							# in all zones on the path from zone X to dst get access to dst.
12198							# (B) rule permit src any:X
12199							# high-level: src gets access to any:X in zone X
12200							# low-level: like above, but additionally, src gets access to all networks
12201							# matching any:X in all zones located directly behind
12202							# all routers on the path from src to zone X.
12203							#
12204							# II. Alternatively, we have a single interface Y (with attached zone Y)
12205							# without ACL and all other interfaces having incoming and outgoing ACLs.
12206							# (A) rule "permit any:X dst"
12207							# a) dst behind Y: filtering occurs at incoming ACL of X, good.
12208							# b) dst not behind Y:
12209							# 1. zone X == zone Y: filtering occurs at outgoing ACL, good.
12210							# 2. zone X != zone Y: outgoing ACL would accidently
12211							# permit any:Y->dst, bad.
12212							# Additional rule required: "permit any:Y->dst"
12213							# (B) rule "permit src any:X"
12214							# a) src behind Y: filtering occurs at ougoing ACL, good
12215							# b) src not behind Y:
12216							# 1. zone X == zone Y: filtering occurs at incoming ACL at src and
12217							# at outgoing ACls of other non-zone X interfaces, good.
12218							# 2. zone X != zone Y: incoming ACL at src would permit
12219							# src->any:Y, bad
12220							# Additional rule required: "permit src->any:Y".
12221							##############################################################################
12222
12223							my %supernet_rule_tree;
12224
12225							# Collect rules with destination aggregate/supernet
12226							# - that are filtered at the same router which is attached
12227							# to the destination zone
12228							# - the destination router is entered by the same interface
12229							# - src, src_range, prt, stateless are identical
12230							# - dst is supernet or aggregate with identical ip/mask
12231							sub collect_supernet_dst_rules {
12232
12233							# Function is called from path_walk.
12234	86			86	0	1138	my ($rule, $in_intf, $out_intf) = @_;
12235
12236							# Source is interface of current router.
12237	86	100				123	return if !$in_intf;
12238
12239							# Ignore semi_managed router.
12240	78					77	my $router = $in_intf->{router};
12241	78	100				129	return if !$router->{managed};
12242
12243	75					70	my $dst = $rule->{dst};
12244	75					65	my $zone = $dst->{zone};
12245	75	100				171	return if $out_intf->{zone} ne $zone;
12246
12247							# Get NAT address of supernet.
12248	54	100				88	if (!$dst->{is_aggregate}) {
12249	21					16	my $no_nat_set = $in_intf->{no_nat_set};
12250	21					31	my $dst = get_nat_network($dst, $no_nat_set);
12251	21	50				51	return if $dst->{hidden};
12252							}
12253
12254	54 54					44 123	my $ipmask = join('/', @{$dst}{qw(ip mask)});
12255	54					73	my ($stateless, $src, $src_range, $prt) =
12256	54					57	@{$rule}{qw(stateless src src_range prt)};
12257	54		50			149	$stateless \|\|= '';
12258	54		33			124	$src_range \|\|= $prt_ip;
12259	54					242	$supernet_rule_tree{$stateless}->{$src}->{$src_range}->{$prt}
12260							->{$in_intf}->{$ipmask}->{$zone} = $rule;
12261	54					98	return;
12262							}
12263
12264							sub find_supernet {
12265	3			3	0	3	my ($net1, $net2) = @_;
12266
12267							# Start with $net1 being the smaller network.
12268	3	100				8	($net1, $net2) = ($net2, $net1) if $net1->{mask} < $net2->{mask};
12269	3					3	while (1) {
12270	4					8	while ($net1->{mask} > $net2->{mask}) {
12271	2	100				7	$net1 = $net1->{up} or return;
12272							}
12273	3	100				10	return $net1 if $net1 eq $net2;
12274	2	100				7	$net2 = $net2->{up} or return;
12275							}
12276	0					0	return; # unused; only for perlcritic
12277							}
12278
12279							# Find networks in zone with address
12280							# - equal to ip/mask or
12281							# - subnet of ip/mask
12282							# Leave out small networks which are subnet of a matching network.
12283							# Result:
12284							# 0: no network found
12285							# network:
12286							# a) exactly one network matches, i.e. is equal or subnet.
12287							# b) a supernet which encloses multiple matching networks
12288							# String: More than one network found and no supernet exists.
12289							# String has the name of first two networks.
12290							sub find_zone_network {
12291	59			59	0	59	my ($interface, $zone, $other) = @_;
12292	59					55	my $no_nat_set = $interface->{no_nat_set};
12293	59					77	my $nat_other = get_nat_network($other, $no_nat_set);
12294	59	50				101	return 0 if $nat_other->{hidden};
12295	59 59					50 85	my ($ip, $mask) = @{$nat_other}{qw(ip mask)};
12296	59					95	my $key = "$ip/$mask";
12297	59	100				115	if (my $aggregate = $zone->{ipmask2aggregate}->{$key}) {
12298	7					13	return $aggregate;
12299							}
12300	52	50				109	if (my $result = $zone->{ipmask2net}->{$key}) {
12301	0					0	return $result;
12302							}
12303
12304							# Real networks in zone without aggregates and without subnets.
12305	52					44	my $networks = $zone->{networks};
12306	52					43	my $result = 0;
12307	52					75	for my $network (@$networks) {
12308	57					65	my $nat_network = get_nat_network($network, $no_nat_set);
12309	57	50				91	next if $nat_network->{hidden};
12310	57 57					50 71	my ($i, $m) = @{$nat_network}{qw(ip mask)};
12311	57	50				138	next if $i =~ /^(?:unnumbered\|tunnel)$/;
12312
12313	57	100	71			216	if ( $m >= $mask && match_ip($i, $ip, $mask)
12314							\|\| $m < $mask && match_ip($ip, $i, $m))
12315							{
12316
12317							# Found first matching network.
12318	24	100				35	if (!$result) {
12319	21					16	$result = $network;
12320	21					37	next;
12321							}
12322
12323							# Search a common supernet of two networks
12324	3	100				9	if (my $super = find_supernet($result, $network)) {
12325	1					2	$result = $super;
12326							}
12327							else {
12328	2					5	$result = "$result->{name}, $network->{name}";
12329	2					4	last;
12330							}
12331							}
12332							}
12333							# debug "zone_network:", ref($result) ? $result->{name} : $result;
12334	52					116	return ($zone->{ipmask2net}->{$key} = $result);
12335							}
12336
12337							# Find all networks in zone, which match network from other zone.
12338							# Result:
12339							# undef: No network of zone matches $other.
12340							# [] : Multiple networks match, but no supernet exists.
12341							# [N, ..]: Array reference to networks which match $other (ascending order).
12342							sub find_matching_supernet {
12343	59			59	0	62	my ($interface, $zone, $other) = @_;
12344	59					79	my $net_or_count = find_zone_network($interface, $zone, $other);
12345
12346							# No network or aggregate matches.
12347							# $other wont match in current zone.
12348	59	100				97	if (!$net_or_count) {
12349	31					38	return;
12350							}
12351
12352							# More than one network matches and no supernet exists.
12353							# Return names of that networks.
12354	28	100				44	if (!ref($net_or_count)) {
12355	2					4	return $net_or_count;
12356							}
12357
12358							# Exactly one network or aggregate matches or supernet exists.
12359	26					28	my @result;
12360
12361							# Add enclosing supernets.
12362	26					30	my $up = $net_or_count;
12363	26					42	while ($up) {
12364	28					30	push @result, $up;
12365	28					53	$up = $up->{up};
12366							}
12367							# debug "matching:", join(',', map { $_->{name} } @result);
12368	26					35	return \@result;
12369							}
12370
12371							# Prevent multiple error messages about missing supernet rules;
12372							my %missing_supernet;
12373
12374							# $rule: the rule to be checked
12375							# $where: has value 'src' or 'dst'
12376							# $interface: interface, where traffic reaches the device,
12377							# this is used to determine no_nat_set
12378							# $zone: The zone to be checked.
12379							# If $where is 'src', then $zone is attached to $interface
12380							# If $where is 'dst', then $zone is at other side of device.
12381							# $reversed: (optional) the check is for reversed rule at stateless device
12382							sub check_supernet_in_zone {
12383	68			68	0	109	my ($rule, $where, $interface, $zone, $reversed) = @_;
12384
12385	68					126	my ($stateless, $deny, $src, $dst, $src_range, $prt) =
12386	68					61	@{$rule}{qw(stateless deny src dst src_range prt)};
12387	68		50			181	$stateless \|\|= '';
12388	68		33			163	$src_range \|\|= $prt_ip;
12389	68	100				96	my $other = $where eq 'src' ? $src : $dst;
12390
12391							# Fast check for access to aggregate/supernet with identical
12392							# ip/mask to $zone.
12393	68	100				102	if ($where eq 'dst') {
12394
12395							# Get NAT address of supernet.
12396	49	100				79	if (!$dst->{is_aggregate}) {
12397	16					17	my $no_nat_set = $interface->{no_nat_set};
12398	16					19	$dst = get_nat_network($dst, $no_nat_set);
12399	16	50				30	return if $dst->{hidden};
12400							}
12401	49 49					42 85	my $ipmask = join('/', @{$dst}{qw(ip mask)});
12402	49	100				233	return if $supernet_rule_tree{$stateless}->{$src}->{$src_range}
12403							->{$prt}->{$interface}->{$ipmask}->{$zone};
12404							}
12405
12406	59					88	my $networks = find_matching_supernet($interface, $zone, $other);
12407	59	100				126	return if not $networks;
12408	28					23	my $extra;
12409	28	100				51	if (!ref($networks)) {
12410	2					3	$extra = "No supernet available for $networks";
12411							}
12412							else {
12413
12414							# $networks holds matching network and all its supernets.
12415							# Find first matching rule.
12416	26		50			73	$deny \|\|= '';
12417	26					32	for my $network (@$networks) {
12418	28	100				43	($where eq 'src' ? $src : $dst) = $network;
12419	28	100				109	if ($rule_tree{$stateless}->{$deny}->{$src_range}->{$src}
12420							->{$dst}->{$prt})
12421							{
12422	17					41	return;
12423							}
12424							}
12425	9 9					11 25	$extra = "Tried " . join(', ', map { $_->{name} } @$networks);
12426							}
12427
12428	11					14	my $service = $rule->{rule}->{service};
12429	11	100				34	return if $missing_supernet{$interface}->{$service};
12430	8					17	$missing_supernet{$interface}->{$service} = 1;
12431
12432	8					10	$rule = print_rule $rule;
12433	8	50				14	$reversed = $reversed ? 'reversed ' : '';
12434	8	50				18	my $print =
12435							$config{check_supernet_rules} eq 'warn' ? \&warn_msg : \&err_msg;
12436	8					51	$print->(
12437							"Missing rule for ${reversed}supernet rule.\n",
12438							" $rule\n",
12439							" can't be effective at $interface->{name}.\n",
12440							" $extra as $where."
12441							);
12442	8					25	return;
12443							}
12444
12445							# If such rule is defined
12446							# permit supernet1 dst
12447							#
12448							# and topology is like this:
12449							#
12450							# supernet1-R1-zone2-R2-zone3-R3-dst
12451							# zone4-/
12452							#
12453							# additional rules need to be defined as well:
12454							# permit supernet(zone2) dst
12455							# permit supernet(zone3) dst
12456							#
12457							# If R2 is stateless, we need one more rule to be defined:
12458							# permit supernet(zone4) dst
12459							# This is so, because at R2 we would get an automatically generated
12460							# reverse rule
12461							# permit dst supernet1
12462							# which would accidentally permit traffic to supernet:[zone4] as well.
12463							sub check_supernet_src_rule {
12464
12465							# Function is called from path_walk.
12466	91			91	0	95	my ($rule, $in_intf, $out_intf) = @_;
12467
12468							# Destination is interface of current router and therefore there is
12469							# nothing to be checked.
12470	91	100				134	return unless $out_intf;
12471
12472							# Ignore semi_managed router.
12473	78					83	my $router = $in_intf->{router};
12474	78	100				118	return if not $router->{managed};
12475
12476	74					68	my $out_zone = $out_intf->{zone};
12477	74					69	my $dst = $rule->{dst};
12478	74					154	my $dst_zone = get_zone($dst);
12479	74	100	100			172	if ($dst->{is_supernet} && $out_zone eq $dst_zone) {
12480
12481							# Both src and dst are supernets and are directly connected
12482							# at current router. Hence there can't be any missing rules.
12483							# Note: Additional checks will be done for this situation at
12484							# check_supernet_dst_rule
12485	8					13	return;
12486							}
12487	66					56	my $in_zone = $in_intf->{zone};
12488
12489							# Check case II, outgoing ACL, (A)
12490	66					51	my $no_acl_intf;
12491	66	100				115	if ($no_acl_intf = $router->{no_in_acl}) {
12492	2					1	my $no_acl_zone = $no_acl_intf->{zone};
12493
12494							# a) dst behind Y
12495	2	50 50 0				8	if ($no_acl_zone eq $dst_zone) {
12496							}
12497
12498							# b), 1. zone X == zone Y
12499							elsif ($in_zone eq $no_acl_zone) {
12500							}
12501
12502							elsif ($no_acl_intf->{main_interface}) {
12503							}
12504
12505							# b), 2. zone X != zone Y
12506							else {
12507	0					0	check_supernet_in_zone($rule, 'src', $no_acl_intf, $no_acl_zone);
12508							}
12509							}
12510	66					61	my $src = $rule->{src};
12511	66					62	my $src_zone = $src->{zone};
12512
12513							# Check if reverse rule would be created and would need additional rules.
12514	66	100	67			137	if ($router->{model}->{stateless} && !$rule->{oneway})
12515
12516							{
12517	4					6	my $proto = $rule->{prt}->{proto};
12518
12519							# Reverse rule wouldn't allow too much traffic, if a non
12520							# secondary stateful device filters between current device and dst.
12521							# This is true if $out_zone and $dst_zone have different
12522							# {stateful_mark}.
12523							# If dst is managed interface, {stateful_mark} is undef
12524							# - if device is secondary managed, take mark of attached network
12525							# - else take value -1, different from all marks.
12526							# $src is supernet (not an interface) by definition
12527							# and hence $m1 is well defined.
12528	4					4	my $m1 = $out_zone->{stateful_mark};
12529	4					3	my $m2 = $dst_zone->{stateful_mark};
12530	4	50				7	if (!$m2) {
12531	0					0	my $managed = $dst->{router}->{managed};
12532	0	0				0	$m2 =
12533							$managed =~ /^(?:secondary\|local.*)$/
12534							? $dst->{network}->{zone}->{stateful_mark}
12535							: -1;
12536							}
12537	4	100	40			24	if (($proto eq 'tcp' \|\| $proto eq 'udp' \|\| $proto eq 'ip')
12538							&& $m1 == $m2)
12539							{
12540
12541							# Check case II, outgoing ACL, (B), interface Y without ACL.
12542	2	50				3	if (my $no_acl_intf = $router->{no_in_acl}) {
12543	0					0	my $no_acl_zone = $no_acl_intf->{zone};
12544
12545							# a) dst behind Y
12546	0	0 0 0				0	if ($no_acl_zone eq $dst_zone) {
12547							}
12548
12549							# b) dst not behind Y
12550							# zone X == zone Y
12551							elsif ($no_acl_zone eq $src_zone) {
12552							}
12553
12554							elsif ($no_acl_intf->{main_interface}) {
12555							}
12556
12557							# zone X != zone Y
12558							else {
12559	0					0	check_supernet_in_zone($rule, 'src', $no_acl_intf,
12560							$no_acl_zone, 1);
12561							}
12562							}
12563
12564							# Standard incoming ACL at all interfaces.
12565							else {
12566
12567							# Find security zones at all interfaces except the in_intf.
12568	2 2					3 2	for my $intf (@{ $router->{interfaces} }) {
12569	4	100				16	next if $intf eq $in_intf;
12570	2	50	33			5	next if $intf->{loopback} && ! $intf->{vip};
12571
12572							# Nothing to be checked for an interface directly
12573							# connected to src or dst.
12574	2					1	my $zone = $intf->{zone};
12575	2	50				5	next if $zone eq $src_zone;
12576	2	50				5	next if $zone eq $dst_zone;
12577	0	0				0	next if $intf->{main_interface};
12578	0					0	check_supernet_in_zone($rule, 'src', $intf, $zone, 1);
12579							}
12580							}
12581							}
12582							}
12583
12584							# Nothing to do at first router.
12585							# zone2 is checked at R2, because we need the no_nat_set at R2.
12586	66	100				166	return if $src_zone eq $in_zone;
12587
12588							# Check if rule "supernet2 -> dst" is defined.
12589	19					36	check_supernet_in_zone($rule, 'src', $in_intf, $in_zone);
12590	19					27	return;
12591							}
12592
12593							# If such rule is defined
12594							# permit src supernet5
12595							#
12596							# and topology is like this:
12597							#
12598							# /-zone4
12599							# src-R1-zone2-R2-zone3-R3-zone5
12600							# \-zone1
12601							#
12602							# additional rules need to be defined as well:
12603							# permit src supernet1
12604							# permit src supernet2
12605							# permit src supernet3
12606							# permit src supernet4
12607							sub check_supernet_dst_rule {
12608
12609							# Function is called from path_walk.
12610	72			72	0	77	my ($rule, $in_intf, $out_intf) = @_;
12611
12612							# Source is interface of current router.
12613	72	100				98	return unless $in_intf;
12614
12615							# Ignore semi_managed router.
12616	71					69	my $router = $in_intf->{router};
12617	71	50				113	return if not $router->{managed};
12618
12619	71					65	my $src = $rule->{src};
12620	71					89	my $src_zone = get_zone($src);
12621	71					74	my $dst = $rule->{dst};
12622	71					72	my $dst_zone = $dst->{zone};
12623
12624							# Check case II, outgoing ACL, (B), interface Y without ACL.
12625	71	100				109	if (my $no_acl_intf = $router->{no_in_acl}) {
12626	7					6	my $no_acl_zone = $no_acl_intf->{zone};
12627
12628							# a) src behind Y
12629	7	100 50 50				20	if ($no_acl_zone eq $src_zone) {
12630							}
12631
12632							# b) src not behind Y
12633							# zone X == zone Y
12634							elsif ($no_acl_zone eq $dst_zone) {
12635							}
12636
12637							elsif ($no_acl_intf->{main_interface}) {
12638							}
12639
12640							# zone X != zone Y
12641							else {
12642	3					4	check_supernet_in_zone($rule, 'dst', $in_intf, $no_acl_zone);
12643							}
12644	7					11	return;
12645							}
12646
12647							# Check security zones at all interfaces except those connected to dst or src.
12648							# For devices which have rules for each pair of incoming and outgoing
12649							# interfaces we only need to check the direct path to dst.
12650	64 50	100				111 66	for my $intf (
12651							$router->{model}->{has_io_acl}
12652							? ($out_intf)
12653							: @{ $router->{interfaces} }
12654							)
12655							{
12656
12657							# Check each intermediate zone only once at outgoing interface.
12658	159	100				302	next if $intf eq $in_intf;
12659	109	100	100			257	next if $intf->{loopback} && ! $intf->{vip};
12660
12661							# Don't check interface where src or dst is attached.
12662	93					79	my $zone = $intf->{zone};
12663	93	100				168	next if $zone eq $src_zone;
12664	92	100				185	next if $zone eq $dst_zone;
12665	46	50				68	next if $intf->{main_interface};
12666	46					64	check_supernet_in_zone($rule, 'dst', $in_intf, $zone);
12667							}
12668	64					91	return;
12669							}
12670
12671							# Optimization:
12672							# Call check_supernet_dst_rule not for every rule with aggregate as destination,
12673							# but only once for a set of rules from collect_supernet_dst_rules.
12674							sub check_supernet_dst_collections {
12675	226	100		226	0	747	return if !keys %supernet_rule_tree;
12676	32					34	my @check_rules;
12677
12678	32					43	for my $src2href (values %supernet_rule_tree) {
12679	32					59	for my $src_range2href (values %$src2href) {
12680	36					46	for my $prt2href (values %$src_range2href) {
12681	36					46	for my $intf2href (values %$prt2href) {
12682	38					49	for my $ipmask2href (values %$intf2href) {
12683
12684							# Check larger aggregates first. To get
12685							# deterministic error messages.
12686	45 4					85 14	for my $ipmask (sort { (split '/', $a)[1] <=>
12687							(split '/', $b)[1] }
12688							keys %$ipmask2href)
12689							{
12690	48					46	my $zone2rule = $ipmask2href->{$ipmask};
12691	48					194	push @check_rules, (values %$zone2rule )[0];
12692							}
12693							}
12694							}
12695							}
12696							}
12697							}
12698	32					37	for my $rule (@check_rules) {
12699	48					78	path_walk($rule, \&check_supernet_dst_rule);
12700							}
12701
12702							# Not used any longer.
12703	32					107	%supernet_rule_tree = ();
12704	32					37	return;
12705							}
12706
12707							# Find smaller protocol of two protocols.
12708							# Cache results.
12709							my %smaller_prt;
12710
12711							sub find_smaller_prt {
12712	8			8	0	8	my ($prt1, $prt2) = @_;
12713
12714	8	50				17	if ($prt1 eq $prt2) {
12715	8					17	return $prt1;
12716							}
12717	0	0				0	if (defined(my $prt = $smaller_prt{$prt1}->{$prt2})) {
12718	0					0	return $prt;
12719							}
12720
12721	0					0	my $prt = $prt1;
12722	0					0	while ($prt = $prt->{up}) {
12723	0	0				0	if ($prt eq $prt2) {
12724	0					0	$smaller_prt{$prt1}->{$prt2} = $prt1;
12725	0					0	$smaller_prt{$prt2}->{$prt1} = $prt1;
12726	0					0	return $prt1;
12727							}
12728							}
12729	0					0	$prt = $prt2;
12730	0					0	while ($prt = $prt->{up}) {
12731	0	0				0	if ($prt eq $prt1) {
12732	0					0	$smaller_prt{$prt1}->{$prt2} = $prt2;
12733	0					0	$smaller_prt{$prt2}->{$prt1} = $prt2;
12734	0					0	return $prt2;
12735							}
12736							}
12737	0					0	$smaller_prt{$prt1}->{$prt2} = 0;
12738	0					0	$smaller_prt{$prt2}->{$prt1} = 0;
12739	0					0	return;
12740							}
12741
12742							# Example:
12743							# XX--R1--any:A--R2--R3--R4--YY
12744							#
12745							# If we have rules
12746							# permit XX any:A
12747							# permit any:B YY
12748							# and
12749							# the intersection I of A and B isn't empty
12750							# and
12751							# XX and YY are subnet of I
12752							# then this traffic is implicitly permitted
12753							# permit XX YY
12754							# which may be undesired.
12755							# In order to avoid this, a warning is generated if the implied rule is not
12756							# explicitly defined.
12757							#
12758							# ToDo:
12759							# Do we need to check for {zone_cluster} equality?
12760							#
12761							# Currently we only check aggregates/supernets with mask = 0.
12762							# Checking of other aggregates is too complicate (NAT, intersection).
12763
12764							# Collect info about unwanted implied rules.
12765							sub check_for_transient_supernet_rule {
12766	226			226	0	188	my %missing_rule_tree;
12767	226					207	my $missing_count = 0;
12768
12769	226 226					185 333	for my $rule (@{ $expanded_rules{supernet} }) {
12770	120	100				190	next if $rule->{deleted};
12771	112	50				170	next if $rule->{deny};
12772	112	50				165	next if $rule->{no_check_supernet_rules};
12773	112					96	my $dst = $rule->{dst};
12774	112	100				201	next if not $dst->{is_supernet};
12775
12776							# Check only 0/0 aggregates.
12777	56	100				108	next if $dst->{mask} != 0;
12778
12779							# A leaf security zone has only one interface.
12780							# It can't lead to unwanted rule chains.
12781	26 26	100				20 62	next if @{ $dst->{zone}->{interfaces} } <= 1;
12782
12783	8					15	my ($stateless1, $src1, $dst1, $src_range1, $prt1) =
12784							@$rule{qw(stateless src dst src_range prt)};
12785	8		50			22	$stateless1 \|\|= '';
12786	8					9	my $deny = '';
12787	8		33			19	$src_range1 \|\|= $prt_ip;
12788
12789							# Find all rules with supernet as source, which intersect with $dst1.
12790	8					7	my $src2 = $dst1;
12791	8					8	for my $stateless2 (1, '') {
12792	16	100				29	my $hash = $rule_tree{$stateless2} or next;
12793	8	50				16	$hash = $hash->{$deny} or next;
12794	8					20	while (my ($src_range2_str, $hash) = each %$hash) {
12795	8					7	my $src_range2 = $ref2prt{$src_range2_str};
12796	8	50				14	my $smaller_src_range =
12797							find_smaller_prt($src_range1, $src_range2) or next;
12798
12799	8	50				41	$hash = $hash->{$src2} or next;
12800	0					0	while (my ($dst2_str, $hash) = each %$hash) {
12801
12802							# Skip reverse rules.
12803	0	0				0	next if $src1 eq $dst2_str;
12804
12805	0					0	my $dst2 = $ref2obj{$dst2_str};
12806
12807							# Skip rules with src and dst inside a single zone.
12808	0	0	0 0			0	next if (($obj2zone{$src1} \|\| get_zone $src1) eq
12809							($obj2zone{$dst2} \|\| get_zone $dst2));
12810
12811							RULE2:
12812	0					0	while (my ($prt2_str, $rule2) = each %$hash) {
12813	0	0				0	next if $rule2->{no_check_supernet_rules};
12814
12815	0					0	my $prt2 = $rule2->{prt};
12816	0		0			0	my $src_range2 = $rule2->{src_range} \|\| $prt_ip;
12817
12818							# Find smaller protocol of two rules found.
12819	0					0	my $smaller_prt = find_smaller_prt($prt1, $prt2);
12820
12821							# If protocols are disjoint, we do not have
12822							# transient-supernet-problem for $rule and $rule2.
12823	0	0				0	next if not $smaller_prt;
12824
12825							# Stateless rule < stateful rule, hence use \|\|.
12826	0		0			0	my $stateless = $stateless1 \|\| $stateless2;
12827
12828							# Check for a rule with $src1 and $dst2 and
12829							# with $smaller_prt.
12830	0					0	while (1) {
12831	0					0	my $deny = '';
12832	0	0				0	if (my $hash = $rule_tree{$stateless}) {
12833	0					0	while (1) {
12834	0					0	my $src_range = $smaller_src_range;
12835	0	0				0	if (my $hash = $hash->{$deny}) {
12836	0					0	while (1) {
12837	0					0	my $src = $src1;
12838	0	0				0	if (my $hash = $hash->{$src_range}) {
12839	0					0	while (1) {
12840	0					0	my $dst = $dst2;
12841	0	0				0	if (my $hash = $hash->{$src}) {
12842	0					0	while (1) {
12843	0					0	my $prt = $smaller_prt;
12844	0	0				0	if (my $hash = $hash->{$dst}) {
12845	0					0	while (1) {
12846	0	0				0	if (my $other_rule = $hash->{$prt}) {
12847
12848							# debug(print_rule $r_rule);
12849	0					0	next RULE2;
12850							}
12851	0	0				0	$prt = $prt->{up} or last;
12852							}
12853							}
12854	0	0				0	$dst = $dst->{up} or last;
12855							}
12856							}
12857	0	0				0	$src = $src->{up} or last;
12858							}
12859							}
12860	0	0				0	$src_range = $src_range->{up} or last;
12861							}
12862							}
12863	0	0				0	last if $deny;
12864	0					0	$deny = 1;
12865							}
12866							}
12867	0	0				0	last if !$stateless;
12868	0					0	$stateless = '';
12869							}
12870
12871							# debug("Src: ", print_rule $rule);
12872							# debug("Dst: ", print_rule $rule2);
12873	0					0	my $src_service = $rule->{rule}->{service}->{name};
12874	0					0	my $dst_service = $rule2->{rule}->{service}->{name};
12875	0					0	my $prt_name = $smaller_prt->{name};
12876	0					0	$prt_name =~ s/^.part_/[part]/;
12877	0	0				0	if ($smaller_src_range ne $prt_ip) {
12878	0 0					0 0	my ($p1, $p2) = @{ $smaller_src_range->{range} };
12879	0					0	$prt_name = "[src:$p1-$p2]$prt_name";
12880							}
12881	0					0	my $new =
12882							not $missing_rule_tree{$src_service}->{$dst_service}
12883
12884							# The matching supernet object.
12885							->{ $dst1->{name} }
12886
12887							# The missing rule
12888							->{ $src1->{name} }->{ $dst2->{name} }->{$prt_name}++;
12889	0	0				0	$missing_count++ if $new;
12890							}
12891							}
12892							}
12893							}
12894							}
12895
12896							# No longer needed; free some memory.
12897	226					241	%smaller_prt = ();
12898
12899	226	50				334	if ($missing_count) {
12900
12901	0	0				0	my $print =
12902							$config{check_transient_supernet_rules} eq 'warn'
12903							? \&warn_msg
12904							: \&err_msg;
12905	0					0	$print->("Missing transient rules: $missing_count");
12906
12907	0					0	while (my ($src_service, $hash) = each %missing_rule_tree) {
12908	0					0	while (my ($dst_service, $hash) = each %$hash) {
12909	0					0	while (my ($supernet, $hash) = each %$hash) {
12910	0					0	info
12911							"Rules of $src_service and $dst_service match at $supernet";
12912	0					0	info("Missing transient rules:");
12913	0					0	while (my ($src, $hash) = each %$hash) {
12914	0					0	while (my ($dst, $hash) = each %$hash) {
12915	0					0	while (my ($prt, $hash) = each %$hash) {
12916	0					0	info(" permit src=$src; dst=$dst; prt=$prt");
12917							}
12918							}
12919							}
12920							}
12921							}
12922							}
12923							}
12924	226					251	return;
12925							}
12926
12927							# Handling of supernet rules created by gen_reverse_rules.
12928							# This is not needed if a stateful and not secondary packet filter is
12929							# located on the path between src and dst.
12930							#
12931							# 1. dst is supernet
12932							#
12933							# src--r1:stateful--dst1=supernet1--r2:stateless--dst2=supernet2
12934							#
12935							# gen_reverse_rule will create one additional rule
12936							# supernet2-->src, but not a rule supernet1-->src, because r1 is stateful.
12937							# check_supernet_src_rule would complain, that supernet1-->src is missing.
12938							# But that doesn't matter, because r1 would permit answer packets
12939							# from supernet2 anyway, because it's stateful.
12940							# Hence we can skip check_supernet_src_rule for this situation.
12941							#
12942							# 2. src is supernet
12943							#
12944							# a) no stateful router on the path between stateless routers and dst.
12945							#
12946							# zone2---\
12947							# src=supernet1--r1:stateless--dst
12948							#
12949							# gen_reverse_rules will create one additional rule dst-->supernet1.
12950							# check_supernet_dst_rule would complain about a missing rule
12951							# dst-->zone2.
12952							# To prevent this situation, check_supernet_src_rule checks for a rule
12953							# zone2 --> dst
12954							#
12955							# b) at least one stateful router on the path between
12956							# stateless router and dst.
12957							#
12958							# zone3---\
12959							# src1=supernet1--r1:stateless--src2=supernet2--r2:stateful--dst
12960							#
12961							# gen_reverse_rules will create one additional rule
12962							# dst-->supernet1, but not dst-->supernet2 because second router is stateful.
12963							# check_supernet_dst_rule would complain about missing rules
12964							# dst-->supernet2 and dst-->supernet3.
12965							# But answer packets back from dst have been filtered by r2 already,
12966							# hence it doesn't hurt if the rules at r1 are a bit too relaxed,
12967							# i.e. r1 would permit dst to zone1 and zone3, but should only
12968							# permit dst to zone1.
12969							# Hence we can skip check_supernet_dst_rule for this situation.
12970							#
12971
12972							# Mark zones connected by stateless or secondary packet filters or by
12973							# semi_managed devices.
12974							sub mark_stateful {
12975	658			658	0	584	my ($zone, $mark) = @_;
12976	658					665	$zone->{stateful_mark} = $mark;
12977	658 658					497 800	for my $in_interface (@{ $zone->{interfaces} }) {
12978	887					781	my $router = $in_interface->{router};
12979	887	100				1232	if ($router->{managed}) {
12980							next
12981	850	100	67			3007	if !$router->{model}->{stateless}
12982							&& $router->{managed} !~ /^(?:secondary\|local.*)$/;
12983							}
12984	237	100				434	next if $router->{active_path};
12985	115					170	local $router->{active_path} = 1;
12986	115 115					98 146	for my $out_interface (@{ $router->{interfaces} }) {
12987	260	100				594	next if $out_interface eq $in_interface;
12988	145					129	my $next_zone = $out_interface->{zone};
12989	145	100				237	next if $next_zone->{stateful_mark};
12990	116					198	mark_stateful($next_zone, $mark);
12991							}
12992							}
12993	658					1036	return;
12994							}
12995
12996							sub check_supernet_rules {
12997	226	50		226	0	403	if ($config{check_supernet_rules}) {
12998	226 120 226					206 182 300	my $count = grep { !$_->{deleted} } @{ $expanded_rules{supernet} };
12999	226					514	progress("Checking $count rules with supernet objects");
13000	226					215	my $stateful_mark = 1;
13001	226					259	for my $zone (@zones) {
13002	658	100				1016	if (not $zone->{stateful_mark}) {
13003	542					740	mark_stateful($zone, $stateful_mark++);
13004							}
13005							}
13006	226 226					213 322	for my $rule (@{ $expanded_rules{supernet} }) {
13007	120	100				200	next if $rule->{deleted};
13008	112	50				162	next if $rule->{no_check_supernet_rules};
13009	112	100				200	if ($rule->{src}->{is_supernet}) {
13010	63					106	path_walk($rule, \&check_supernet_src_rule);
13011							}
13012	112	100				228	if ($rule->{dst}->{is_supernet}) {
13013	56					97	path_walk($rule, \&collect_supernet_dst_rules);
13014							}
13015							}
13016	226					347	check_supernet_dst_collections();
13017	226					283	%missing_supernet = ();
13018							}
13019	226	50				388	if ($config{check_transient_supernet_rules}) {
13020	226					302	check_for_transient_supernet_rule();
13021							}
13022
13023							# no longer needed; free some memory.
13024	226					279	%obj2zone = ();
13025	226					185	return;
13026							}
13027
13028							##############################################################################
13029							# Generate reverse rules for stateless packet filters:
13030							# For each rule with protocol tcp, udp or ip we need a reverse rule
13031							# with swapped src, dst and src-port, dst-port.
13032							# For rules with a tcp protocol, the reverse rule gets a tcp protocol
13033							# without range checking but with checking for 'established` flag.
13034							##############################################################################
13035
13036							sub gen_reverse_rules1 {
13037	678			678	0	577	my ($rule_aref, $rule_tree) = @_;
13038	678					478	my @extra_rules;
13039							my %cache;
13040	678					732	for my $rule (@$rule_aref) {
13041	524	100				821	if ($rule->{deleted}) {
13042	21					20	my $src = $rule->{src};
13043
13044							# If source is a managed interface,
13045							# reversed will get attribute managed_intf.
13046	21	50	25			30	unless (is_interface($src) && ($src->{router}->{managed} \|\|
13047							$src->{router}->{routing_only}))
13048							{
13049	21					33	next;
13050							}
13051							}
13052	503					455	my $prt = $rule->{prt};
13053	503					497	my $proto = $prt->{proto};
13054	503	100	100			1306	next unless $proto eq 'tcp' or $proto eq 'udp' or $proto eq 'ip';
13055	447	50				618	next if $rule->{oneway};
13056
13057							# No reverse rules will be generated for denied TCP packets, because
13058							# - there can't be an answer if the request is already denied and
13059							# - the 'established' optimization for TCP below would produce
13060							# wrong results.
13061	447	50	67			1244	next if $proto eq 'tcp' and $rule->{deny};
13062
13063	447					377	my $src = $rule->{src};
13064	447					372	my $dst = $rule->{dst};
13065	447		67			948	my $from_store = $obj2path{$src} \|\| get_path $src;
13066	447		67			868	my $to_store = $obj2path{$dst} \|\| get_path $dst;
13067	447					721	my $has_stateless_router = $cache{$from_store}->{$to_store};
13068	447	100				658	if (!defined $has_stateless_router) {
13069							PATH_WALK:
13070							{
13071
13072							# Local function.
13073							# It uses free variable $has_stateless_router.
13074	287					228	my $mark_reverse_rule = sub {
13075	433			433		434	my ($rule, $in_intf, $out_intf) = @_;
13076
13077							# Destination of current rule is current router.
13078							# Outgoing packets from a router itself are never filtered.
13079							# Hence we don't need a reverse rule for current router.
13080	433	100				625	return if not $out_intf;
13081	379					363	my $router = $out_intf->{router};
13082
13083							# It doesn't matter if a semi_managed device is stateless
13084							# because no code is generated.
13085	379	100				557	return if not $router->{managed};
13086	367					347	my $model = $router->{model};
13087
13088	367	100	75			1170	if (
13089							$model->{stateless}
13090
13091							# Source of current rule is current router.
13092							or not $in_intf and $model->{stateless_self}
13093							)
13094							{
13095	66					55	$has_stateless_router = 1;
13096
13097							# Jump out of path_walk.
13098	70 70 70			70		463 100 2482621	no warnings "exiting"; ## no critic (ProhibitNoWarn)
13099	66	50				141	last PATH_WALK if $use_nonlocal_exit;
13100							}
13101	287					839	};
13102	287					424	path_walk($rule, $mark_reverse_rule);
13103							}
13104	287		100			1019	$cache{$from_store}->{$to_store} = $has_stateless_router \|\| 0;
13105							}
13106	447	100				938	if ($has_stateless_router) {
13107	69					116	my $new_src_range;
13108							my $new_prt;
13109	69	100 100 50				118	if ($proto eq 'tcp') {
13110	49					56	$new_prt = $range_tcp_established;
13111							}
13112							elsif ($proto eq 'udp') {
13113
13114							# Swap src and dst range.
13115	13					12	$new_src_range = $rule->{prt};
13116	13	100				29	if ($new_src_range->{range} eq $aref_tcp_any) {
13117	1					1	$new_src_range = undef;
13118							}
13119	13					16	$new_prt = $rule->{src_range};
13120	13	100				19	if (not $new_prt) {
13121	5					6	$new_prt = $prt_udp->{dst_range};
13122							}
13123							}
13124							elsif ($proto eq 'ip') {
13125	7					5	$new_prt = $prt;
13126							}
13127							else {
13128	0					0	internal_err();
13129							}
13130	69					143	my $new_rule = {
13131
13132							# This rule must only be applied to stateless routers.
13133							stateless => 1,
13134							src => $dst,
13135							dst => $src,
13136							prt => $new_prt,
13137							};
13138	69	100				107	$new_rule->{src_range} = $new_src_range if $new_src_range;
13139	69	50				116	$new_rule->{deny} = 1 if $rule->{deny};
13140
13141							# Don't push to @$rule_aref while we are iterating over it.
13142	69					143	push @extra_rules, $new_rule;
13143							}
13144							}
13145	678					629	push @$rule_aref, @extra_rules;
13146	678					841	add_rules(\@extra_rules, $rule_tree);
13147	678					1095	return;
13148							}
13149
13150							sub gen_reverse_rules {
13151	226			226	0	299	progress('Generating reverse rules for stateless routers');
13152	226					183	my %reverse_rule_tree;
13153	226					271	for my $type ('deny', 'supernet', 'permit') {
13154	678					1029	gen_reverse_rules1($expanded_rules{$type}, \%reverse_rule_tree);
13155							}
13156	226	100				473	if (keys %reverse_rule_tree) {
13157	38					56	print_rulecount;
13158	38					51	progress('Optimizing reverse rules');
13159	38					60	optimize_rules(\%rule_tree, \%reverse_rule_tree);
13160	38					52	print_rulecount;
13161							}
13162
13163							# Not longer used, free memory.
13164	226					584	%rule_tree = ();
13165	226					302	return;
13166							}
13167
13168							##############################################################################
13169							# Mark rules for secondary filtering.
13170							# A rule is implemented at a device
13171							# either as a 'typical' or as a 'secondary' filter.
13172							# A filter is called to be 'secondary' if it only checks
13173							# for the source and destination network and not for the protocol.
13174							# A typical filter checks for full source and destination IP and
13175							# for the protocol of the rule.
13176							#
13177							# There are four types of packet filters: secondary, standard, full, primary.
13178							# A rule is marked by two attributes which are determined by the type of
13179							# devices located on the path from source to destination.
13180							# - 'some_primary': at least one device is primary packet filter,
13181							# - 'some_non_secondary': at least one device is not secondary packet filter.
13182							# A rule is implemented as a secondary filter at a device if
13183							# - the device is secondary and the rule has attribute 'some_non_secondary' or
13184							# - the device is standard and the rule has attribute 'some_primary'.
13185							# Otherwise a rules is implemented typical.
13186							##############################################################################
13187
13188							sub get_zone2 {
13189	1944			1944	0	1477	my ($obj) = @_;
13190	1944					1676	my $type = ref $obj;
13191	1944	100 100 50				3029	if ($type eq 'Network') {
13192	1202					1427	return $obj->{zone};
13193							}
13194							elsif ($type eq 'Subnet') {
13195	201					273	return $obj->{network}->{zone};
13196							}
13197							elsif ($type eq 'Interface') {
13198	541					657	return $obj->{network}->{zone};
13199							}
13200							}
13201
13202							# Mark security zone $zone with $mark and
13203							# additionally mark all security zones
13204							# which are connected with $zone by secondary packet filters.
13205							sub mark_secondary;
13206
13207							sub mark_secondary {
13208	658			658	0	544	my ($zone, $mark) = @_;
13209	658					667	$zone->{secondary_mark} = $mark;
13210
13211							# debug("$zone->{name} $mark");
13212	658 658					499 783	for my $in_interface (@{ $zone->{interfaces} }) {
13213	887	100				1285	next if $in_interface->{main_interface};
13214	845					713	my $router = $in_interface->{router};
13215	845	100				1280	if (my $managed = $router->{managed}) {
13216	809	100				2252	next if $managed !~ /^(?:secondary\|local.*)$/;
13217							}
13218	116	100				227	next if $router->{active_path};
13219	54					80	local $router->{active_path} = 1;
13220	54 54					46 68	for my $out_interface (@{ $router->{interfaces} }) {
13221	121	100				280	next if $out_interface eq $in_interface;
13222	67	100				101	next if $out_interface->{main_interface};
13223	64					59	my $next_zone = $out_interface->{zone};
13224	64	100				98	next if $next_zone->{secondary_mark};
13225	62					107	mark_secondary $next_zone, $mark;
13226							}
13227							}
13228	658					805	return;
13229							}
13230
13231							# Mark security zone $zone with $mark and
13232							# additionally mark all security zones
13233							# which are connected with $zone by non-primary packet filters.
13234							# Test for {active_path} has been added to prevent deep recursion.
13235							sub mark_primary;
13236
13237							sub mark_primary {
13238	658			658	0	563	my ($zone, $mark) = @_;
13239	658					650	$zone->{primary_mark} = $mark;
13240	658 658					467 786	for my $in_interface (@{ $zone->{interfaces} }) {
13241	887	100				1229	next if $in_interface->{main_interface};
13242	845					724	my $router = $in_interface->{router};
13243	845	100				1213	if (my $managed = $router->{managed}) {
13244	809	100				1153	next if $managed eq 'primary';
13245							}
13246	843	100				1425	next if $router->{active_path};
13247	412					525	local $router->{active_path} = 1;
13248	412 412					310 497	for my $out_interface (@{ $router->{interfaces} }) {
13249	999	100				1978	next if $out_interface eq $in_interface;
13250	587	100				873	next if $out_interface->{main_interface};
13251	526					460	my $next_zone = $out_interface->{zone};
13252	526	100				785	next if $next_zone->{primary_mark};
13253	419					573	mark_primary $next_zone, $mark;
13254							}
13255							}
13256	658					1102	return;
13257							}
13258
13259							# Mark security zone $zone with $mark and
13260							# additionally mark all security zones
13261							# which are connected with $zone by non-strict-secondary
13262							# packet filters.
13263							sub mark_strict_secondary;
13264
13265							sub mark_strict_secondary {
13266	658			658	0	542	my ($zone, $mark) = @_;
13267	658					660	$zone->{strict_secondary_mark} = $mark;
13268							# debug "$zone->{name} : $mark";
13269	658 658					479 774	for my $in_interface (@{ $zone->{interfaces} }) {
13270	887	100				1220	next if $in_interface->{main_interface};
13271	845					703	my $router = $in_interface->{router};
13272	845	100				1197	if ($router->{managed}) {
13273	809	50				1110	next if $router->{strict_secondary};
13274							}
13275	845	100				1399	next if $router->{active_path};
13276	413					491	local $router->{active_path} = 1;
13277	413 413					294 477	for my $out_interface (@{ $router->{interfaces} }) {
13278	1001	100				1916	next if $out_interface eq $in_interface;
13279	588	100				849	next if $out_interface->{main_interface};
13280	527					456	my $next_zone = $out_interface->{zone};
13281	527	100				803	next if $next_zone->{strict_secondary_mark};
13282	420					537	mark_strict_secondary($next_zone, $mark);
13283							}
13284							}
13285	658					1040	return;
13286							}
13287
13288							# Mark security zone $zone with $mark and additionally mark all
13289							# security zones which are connected with $zone by local_secondary
13290							# packet filters.
13291							sub mark_local_secondary;
13292
13293							sub mark_local_secondary {
13294	658			658	0	523	my ($zone, $mark) = @_;
13295	658					660	$zone->{local_secondary_mark} = $mark;
13296							# debug "local_secondary $zone->{name} : $mark";
13297	658 658					492 750	for my $in_interface (@{ $zone->{interfaces} }) {
13298	887	100				1272	next if $in_interface->{main_interface};
13299	845					670	my $router = $in_interface->{router};
13300	845	100				1247	if (my $managed = $router->{managed}) {
13301	809	100				1566	next if $managed ne 'local_secondary';
13302							}
13303	46	100				92	next if $router->{active_path};
13304	21					27	local $router->{active_path} = 1;
13305	21 21					24 31	for my $out_interface (@{ $router->{interfaces} }) {
13306	47	100				101	next if $out_interface eq $in_interface;
13307	26	100				50	next if $out_interface->{main_interface};
13308	25					21	my $next_zone = $out_interface->{zone};
13309	25	50				44	next if $next_zone->{local_secondary_mark};
13310	25					47	mark_local_secondary($next_zone, $mark);
13311							}
13312							}
13313	658					907	return;
13314							}
13315
13316							sub mark_secondary_rules {
13317	226			226	0	306	progress('Marking rules for secondary optimization');
13318
13319	226					195	my $secondary_mark = 1;
13320	226					189	my $primary_mark = 1;
13321	226					182	my $strict_secondary_mark = 1;
13322	226					185	my $local_secondary_mark = 1;
13323	226					261	for my $zone (@zones) {
13324	658	100				970	if (not $zone->{secondary_mark}) {
13325	596					824	mark_secondary $zone, $secondary_mark++;
13326							}
13327	658	100				1064	if (not $zone->{primary_mark}) {
13328	239					372	mark_primary $zone, $primary_mark++;
13329							}
13330	658	100				995	if (not $zone->{strict_secondary_mark}) {
13331	238					334	mark_strict_secondary($zone, $strict_secondary_mark++);
13332							}
13333	658	100				973	if (not $zone->{local_secondary_mark}) {
13334	633					817	mark_local_secondary($zone, $local_secondary_mark++);
13335							}
13336							}
13337
13338							# Mark only normal rules for secondary optimization.
13339							# Don't modify a deny rule from e.g. tcp to ip.
13340							# Don't modify supernet rules, because path isn't fully known.
13341	226 226 226					219 263 306	for my $rule (@{ $expanded_rules{permit} }, @{ $expanded_rules{supernet} })
13342							{
13343							next
13344	593	100	50			955	if $rule->{deleted}
13345							and
13346							(not $rule->{managed_intf} or $rule->{deleted}->{managed_intf});
13347
13348	560 560					433 669	my ($src, $dst) = @{$rule}{qw(src dst)};
13349	560	100	100			1663	next if $src->{is_aggregate} \|\| $dst->{is_aggregate};
13350	468					524	my $src_zone = get_zone2($src);
13351	468					516	my $dst_zone = get_zone2($dst);
13352
13353	468	100	67			1129	if ($src_zone->{secondary_mark} != $dst_zone->{secondary_mark} \|\|
13354
13355							# Local secondary optimization.
13356							$src_zone->{local_mark} && $dst_zone->{local_mark} &&
13357							$src_zone->{local_mark} == $dst_zone->{local_mark} &&
13358							$src_zone->{local_secondary_mark} !=
13359							$dst_zone->{local_secondary_mark})
13360							{
13361	359					394	$rule->{some_non_secondary} = 1;
13362							}
13363	468	100				758	if ($src_zone->{primary_mark} != $dst_zone->{primary_mark}) {
13364	1					2	$rule->{some_primary} = 1;
13365							}
13366
13367							# A device with attribute 'strict_secondary' is located
13368							# between src and dst.
13369							# Each rule must
13370							# - either be optimized secondary
13371							# - or be simple:
13372							# - protocol IP
13373							# - src and dst be either
13374							# - network
13375							# - loopback interface
13376							# - interface of managed device
13377	468	100				966	if ($src_zone->{strict_secondary_mark} !=
13378							$dst_zone->{strict_secondary_mark})
13379							{
13380	1	50				3	if (!$rule->{some_non_secondary}) {
13381	0					0	my $err;
13382	0					0	my ($src, $dst, $prt) =
13383	0					0	@{$rule}{ qw(src dst prt) };
13384	0	0				0	if ($prt ne $prt_ip) {
13385	0					0	$err = "'prt = ip'";
13386							}
13387							else {
13388	0					0	for my $where (qw(src dst)) {
13389	0					0	my $what = $rule->{$where};
13390	0	0	0			0	if (!is_network($what) &&
13391							!(is_interface($what) &&
13392							($what->{loopback} \|\|
13393							$what->{router}->{managed})))
13394							{
13395	0					0	$err =
13396							"network or managed/loopback interface as "
13397							. $where;
13398	0					0	last;
13399							}
13400							}
13401							}
13402	0	0				0	if ($err) {
13403	0					0	err_msg("Invalid rule at router with attribute",
13404							" 'strict_secondary'.\n",
13405							" Rule must only use $err.\n ", print_rule($rule));
13406							}
13407							}
13408							}
13409							}
13410	226					268	return;
13411							}
13412
13413
13414							# - Check for partially applied hidden or dynamic NAT on path.
13415							# - Check for invalid rules accessing hidden objects.
13416							# - Find rules where dynamic NAT is applied to host or interface at
13417							# src or dst on path to other end of rule.
13418							# Mark found rule with attribute {dynamic_nat} and value src\|dst\|src,dst.
13419							sub mark_dynamic_nat_rules {
13420	226			226	0	289	progress('Marking rules with dynamic NAT');
13421
13422							# Mapping from nat_tag to boolean.
13423							# Value is true if hidden NAT, false if dynamic NAT.
13424	226					198	my %dynamic_nat2hidden;
13425	226					253	for my $network (@networks) {
13426	938	100				1536	my $href = $network->{nat} or next;
13427	69					142	for my $nat_tag (sort keys %$href) {
13428	76					81	my $nat_network = $href->{$nat_tag};
13429	76	100				140	$nat_network->{dynamic} or next;
13430	53					115	$dynamic_nat2hidden{$nat_tag} = $nat_network->{hidden};
13431							}
13432							}
13433
13434							# Check path for partially applied hidden or dynamic NAT.
13435							my $check_dyn_nat = sub {
13436	61			61		66	my ($rule, $in_intf, $out_intf) = @_;
13437	61	100				99	my $no_nat_set1 = $in_intf ? $in_intf->{no_nat_set} : undef;
13438	61	100				75	my $no_nat_set2 = $out_intf ? $out_intf->{no_nat_set} : undef;
13439	61					93	for my $nat_tag (keys %dynamic_nat2hidden) {
13440	67	100				96	if ($no_nat_set1) {
13441	39					68	$no_nat_set1->{$nat_tag} or
13442	64	100				111	push @{ $rule->{active_nat_at}->{$nat_tag} }, $in_intf;
13443							}
13444	67	100				98	if ($no_nat_set2) {
13445	29					74	$no_nat_set2->{$nat_tag} or
13446	63	100				137	push @{ $rule->{active_nat_at}->{$nat_tag} }, $out_intf;
13447							}
13448							}
13449	226					766	};
13450
13451	226					207	my %cache;
13452
13453	226 226					199 268	for my $rule (
13454	226					242	@{ $expanded_rules{permit} },
13455	226					301	@{ $expanded_rules{supernet} },
13456							@{ $expanded_rules{deny} }
13457							)
13458							{
13459							next
13460	593	100	50			942	if $rule->{deleted}
13461							and
13462							(not $rule->{managed_intf} or $rule->{deleted}->{managed_intf});
13463
13464	560					384	my $dynamic_nat;
13465	560					509	for my $where ('src', 'dst') {
13466	1120					991	my $obj = $rule->{$where};
13467	1120					946	my $type = ref $obj;
13468	1120	100				1330	my $network =
13469							($type eq 'Network')
13470							? $obj
13471							: $obj->{network};
13472	1120	100				2028	my $nat_hash = $network->{nat} or next;
13473	77	100				112	my $other = $where eq 'src' ? $rule->{dst} : $rule->{src};
13474	77					70	my $otype = ref $other;
13475	77	100				111	my $nat_domain = ($otype eq 'Network')
13476							? $other->{nat_domain} # Is undef for aggregate.
13477							: $other->{network}->{nat_domain};
13478	77					55	my $hidden_seen;
13479							my $dynamic_seen;
13480	0					0	my $static_seen;
13481
13482							# Find $nat_tag which is effective at $other.
13483							# - single: $other is host or network, $nat_domain is known.
13484							# - multiple: $other is aggregate.
13485							# Check all NAT domains at border of corresponding zone.
13486	77 2	100				131 3	for my $no_nat_set ( $nat_domain
13487							? ($nat_domain->{no_nat_set})
13488	1					2	: map({ $_->{no_nat_set} }
13489							@{ $other->{zone}->{interfaces} }))
13490							{
13491	78					66	my $nat_found;
13492	78					126	for my $nat_tag (sort keys %$nat_hash) {
13493	78	100				135	next if $no_nat_set->{$nat_tag};
13494	64					54	$nat_found = 1;
13495	64					62	my $nat_network = $nat_hash->{$nat_tag};
13496
13497							# Network is hidden by NAT.
13498	64	100				104	if ($nat_network->{hidden}) {
13499	3	50				13	$hidden_seen++ or
13500							err_msg("$obj->{name} is hidden by nat:$nat_tag",
13501							" in rule\n ",
13502							print_rule $rule);
13503	3					6	next;
13504							}
13505	61	100				91	if (!$nat_network->{dynamic}) {
13506	13					9	$static_seen = 1;
13507	13					20	next;
13508							}
13509
13510							# Network has dynamic NAT.
13511	48	50				66	$dynamic_seen and next;
13512	48	100	100			159	$type eq 'Subnet' or $type eq 'Interface' or next;
13513
13514							# Host / interface doesn't have static NAT.
13515	24	100				57	$obj->{nat}->{$nat_tag} and next;
13516
13517							# Check error condition: Dynamic NAT address is
13518							# used in ACL at managed router at the border of
13519							# zone of $obj.
13520							# $intf could have value 'undef' if $obj is interface of
13521							# current router and destination of rule.
13522							my $check = sub {
13523	10			10		10	my ($rule, $in_intf, $out_intf) = @_;
13524	10					11	my $no_nat_set = $in_intf->{no_nat_set};
13525	10					11	my $nat_network =
13526							get_nat_network($network, $no_nat_set);
13527	10					12	my $nat_tag = $nat_network->{dynamic};
13528	10	100				15	return if not $nat_tag;
13529	7	50				13	return if $obj->{nat}->{$nat_tag};
13530	7	100				10	my $intf = $where eq 'src' ? $in_intf : $out_intf;
13531	7	100	67			19	if (!$intf \|\|
13532							zone_eq($network->{zone}, $intf->{zone}))
13533							{
13534	5					19	err_msg "$obj->{name} needs static translation",
13535							" for nat:$nat_tag to be valid in rule\n ",
13536							print_rule $rule;
13537							}
13538	7					28	};
13539	7					8	path_walk($rule, $check);
13540
13541	7	50				8	$dynamic_nat =
13542							$dynamic_nat
13543							? "$dynamic_nat,$where"
13544							: $where;
13545
13546							# debug("dynamic_nat: $where at ", print_rule $rule);
13547	7					34	$dynamic_seen = 1;
13548							}
13549	78	100				166	$nat_found or $static_seen = 1;
13550							}
13551
13552	77	100				109	$hidden_seen and next;
13553
13554							# Check error conditition:
13555							# Find sub-path where dynamic / hidden NAT is enabled,
13556							# i.e. dynamic / hidden NAT is enabled first and disabled later.
13557
13558							# Find dynamic and hidden NAT definitions of $obj.
13559							# Key: NAT tag,
13560							# value: boolean, true=hidden, false=dynamic
13561	74					61	my $dyn_nat_hash;
13562	74					108	for my $nat_tag (keys %$nat_hash) {
13563	74					77	my $nat_network = $nat_hash->{$nat_tag};
13564	74	100				118	$nat_network->{dynamic} or next;
13565	60					118	$dyn_nat_hash->{$nat_tag} = $nat_network->{hidden};
13566							}
13567	74	100				133	$dyn_nat_hash or next;
13568
13569	54		67			115	my $from_store = $obj2path{$obj} \|\| get_path $obj;
13570	54		67			100	my $to_store = $obj2path{$other} \|\| get_path $other;
13571	54		67			191	my $active_nat_at =
13572							$cache{$from_store}->{$to_store} \|\|
13573							$cache{$to_store}->{$from_store};
13574
13575	54	100				75	if (!$active_nat_at) {
13576	35					80	$cache{$from_store}->{$to_store} =
13577							$active_nat_at = $rule->{active_nat_at} = {};
13578	35					61	path_walk($rule, $check_dyn_nat);
13579	35					51	delete $rule->{active_nat_at};
13580							}
13581
13582	54					121	for my $nat_tag (sort keys %$dyn_nat_hash) {
13583	60	100				127	my $interfaces = $active_nat_at->{$nat_tag} or next;
13584	53					46	my $is_hidden = $dyn_nat_hash->{$nat_tag};
13585	53	100	100			251	($is_hidden \|\| $static_seen) or next;
13586	12					24	my $names =
13587	5					10	join("\n - ", map({ $_->{name} } sort(by_name @$interfaces)));
13588	5	100				10	my $type = $is_hidden ? 'hidden' : 'dynamic';
13589	5	50				17	err_msg("Must not apply $type NAT '$nat_tag' on path\n",
13590							" of", $where eq 'dst' ? ' reversed' : '', " rule\n",
13591							" ", print_rule($rule), "\n",
13592							" NAT '$nat_tag' is active at\n",
13593							" - $names\n",
13594							" Add pathrestriction",
13595							" to exclude this path");
13596							}
13597							}
13598	560	100				966	$rule->{dynamic_nat} = $dynamic_nat if $dynamic_nat;
13599							}
13600	226					1104	return;
13601							}
13602
13603							##############################################################################
13604							# Optimize expanded rules by deleting identical rules and
13605							# rules which are overlapped by a more general rule
13606							##############################################################################
13607
13608							sub optimize_rules {
13609	264			264	0	264	my ($cmp_hash, $chg_hash) = @_;
13610	264					652	while (my ($stateless, $chg_hash) = each %$chg_hash) {
13611	230					183	while (1) {
13612	268	100				455	if (my $cmp_hash = $cmp_hash->{$stateless}) {
13613	230					532	while (my ($deny, $chg_hash) = each %$chg_hash) {
13614	230					175	while (1) {
13615	460	100				751	if (my $cmp_hash = $cmp_hash->{$deny}) {
13616	230					520	while (my ($src_range_ref, $chg_hash) = each %$chg_hash) {
13617	256					236	my $src_range = $ref2prt{$src_range_ref};
13618	256					195	while (1) {
13619	322	100				608	if (my $cmp_hash = $cmp_hash->{$src_range}) {
13620	280					570	while (my ($src_ref, $chg_hash) = each %$chg_hash) {
13621	475					428	my $src = $ref2obj{$src_ref};
13622	475					680	while (1) {
13623	785	100				1391	if (my $cmp_hash = $cmp_hash->{$src}) {
13624	462					889	while (my ($dst_ref, $chg_hash) = each %$chg_hash) {
13625	591					854	my $dst = $ref2obj{$dst_ref};
13626	591					449	while (1) {
13627	966	100				1683	if (my $cmp_hash = $cmp_hash->{$dst}) {
13628	595					1165	for my $chg_rule (values %$chg_hash) {
13629
13630							# Even if $change_rule already is marked as deleted,
13631							# don't stop here, but go on and find all redundant
13632							# pairs of ($change_rule, $cmp_rule).
13633							# This is needed, because some instances of $cmp_rule
13634							# may have an {overlaps} attribute, which prevents
13635							# a warning message to be printed.
13636	627					562	my $prt = $chg_rule->{prt};
13637	627		100			1510	my $chg_log = $chg_rule->{log} \|\| '';
13638	627					454	while (1) {
13639	1703	100				2743	if (my $cmp_rule = $cmp_hash->{$prt}) {
13640	556		100			1246	my $cmp_log = $cmp_rule->{log} \|\| '';
13641	556	100	100			2294	if ($cmp_rule ne $chg_rule && $cmp_log eq $chg_log) {
13642							# debug("Del:", print_rule $chg_rule);
13643							# debug("Oth:", print_rule $cmp_rule);
13644	32					34	$chg_rule->{deleted} = $cmp_rule;
13645	32					107	collect_redundant_rules($chg_rule, $cmp_rule);
13646	32					64	last;
13647							}
13648							}
13649	1671	100				3011	$prt = $prt->{up} or last;
13650							}
13651							}
13652							}
13653	966	100				2348	$dst = $dst->{up} or last;
13654							}
13655							}
13656							}
13657	785	100				1767	$src = $src->{up} or last;
13658							}
13659							}
13660							}
13661	322	100				826	$src_range = $src_range->{up} or last;
13662							}
13663							}
13664							}
13665	460	100				886	last if $deny;
13666	230					226	$deny = 1;
13667							}
13668							}
13669							}
13670	268	100				646	last if !$stateless;
13671	38					44	$stateless = '';
13672							}
13673							}
13674	264					264	return;
13675							}
13676
13677							sub optimize_and_warn_deleted {
13678	226			226	0	631	progress('Optimizing globally');
13679	226					330	setup_ref2obj();
13680	226					423	optimize_rules(\%rule_tree, \%rule_tree);
13681	226					332	print_rulecount();
13682	226					313	show_deleted_rules2();
13683	226					323	warn_unused_overlaps();
13684	226					184	return;
13685							}
13686
13687							########################################################################
13688							# Prepare NAT commands
13689							########################################################################
13690
13691							# Collect devices which need NAT commands.
13692							sub collect_nat_path {
13693	387			387	0	364	my ($rule, $in_intf, $out_intf) = @_;
13694
13695							# No NAT needed for directly attached interface.
13696	387	100				564	return unless $out_intf;
13697
13698							# No NAT needed for traffic originating from the device itself.
13699	324	100				453	return unless $in_intf;
13700
13701	293					276	my $router = $out_intf->{router};
13702	293	100				456	return unless $router->{managed};
13703	279					247	my $model = $router->{model};
13704	279	100				523	return unless $model->{has_interface_level};
13705
13706	122 122					103 271	push @{ $rule->{nat_path} }, [ $in_intf, $out_intf ];
13707	122					160	return;
13708							}
13709
13710							# Distribute networks needing NAT commands to device.
13711							sub distribute_nat_to_device {
13712	122			122	0	109	my ($pair, $src_net, $dst_net) = @_;
13713	122					129	my ($in_intf, $out_intf) = @$pair;
13714	122					112	my $router = $out_intf->{router};
13715	122					115	my $model = $router->{model};
13716
13717							# We need in_hw and out_hw for
13718							# - attaching attribute src_nat and
13719							# - getting the NAT tag.
13720	122					107	my $in_hw = $in_intf->{hardware};
13721	122					103	my $out_hw = $out_intf->{hardware};
13722
13723	122					130	my $identity_nat = $model->{need_identity_nat};
13724	122	100 100				281	if ($identity_nat) {
13725
13726							# Static dst NAT is equivalent to reversed src NAT.
13727	1					1	for my $dst (@$dst_net) {
13728	1					4	$out_hw->{src_nat}->{$in_hw}->{$dst} = $dst;
13729							}
13730	1	50				3	if ($in_hw->{level} > $out_hw->{level}) {
13731	0					0	$in_hw->{need_nat_0} = 1;
13732							}
13733							}
13734
13735							# Not identity NAT, handle real dst NAT.
13736							elsif (my $nat_tags = $in_hw->{bind_nat}) {
13737	11					13	for my $dst (@$dst_net) {
13738	11	50				16	my $nat_info = $dst->{nat} or next;
13739	11 11	50				19 25	grep({ $nat_info->{$_} } @$nat_tags) or next;
13740
13741							# Store reversed dst NAT for real translation.
13742	11					39	$out_hw->{src_nat}->{$in_hw}->{$dst} = $dst;
13743							}
13744							}
13745
13746							# Handle real src NAT.
13747							# Remember:
13748							# NAT tag for network located behind in_hw is attached to out_hw.
13749	122	100				1393	my $nat_tags = $out_hw->{bind_nat} or return;
13750	14					15	for my $src (@$src_net) {
13751	17	100				36	my $nat_info = $src->{nat} or next;
13752
13753							# We can be sure to get a single result.
13754							# Binding for different NAT of a single network has been
13755							# rejected in distribute_nat_info.
13756	11 11	50 50				13 42	my ($nat_net) = map({ $nat_info->{$_} \|\| () } @$nat_tags) or next;
13757
13758							# Store src NAT for real translation.
13759	11					28	$in_hw->{src_nat}->{$out_hw}->{$src} = $src;
13760
13761	11	50				29	if ($identity_nat) {
13762
13763							# Check if there is a dynamic NAT of src address from lower
13764							# to higher security level. We need this info to decide,
13765							# if static commands with "identity mapping" and a "nat 0" command
13766							# need to be generated.
13767	0	0	0			0	if ($nat_net->{dynamic} and $in_hw->{level} < $out_hw->{level}) {
13768	0					0	$in_hw->{need_identity_nat} = 1;
13769	0					0	$in_hw->{need_nat_0} = 1;
13770							}
13771							}
13772							}
13773	14					44	return;
13774							}
13775
13776							sub get_zone3 {
13777	480			480	0	403	my ($obj) = @_;
13778	480					458	my $type = ref $obj;
13779	480	100 100 50				772	if ($type eq 'Network') {
13780	320					736	return $obj->{zone};
13781							}
13782							elsif ($type eq 'Subnet') {
13783	44					114	return $obj->{network}->{zone};
13784							}
13785							elsif ($type eq 'Interface') {
13786	116					114	my $router = $obj->{router};
13787	116	100	100			283	if ($router->{managed} or $router->{semi_managed}) {
13788	64					145	return $obj;
13789							}
13790							else {
13791	52					123	return $obj->{network}->{zone};
13792							}
13793							}
13794							else {
13795	0					0	internal_err();
13796							}
13797							}
13798
13799							sub get_networks {
13800	217			217	0	192	my ($obj) = @_;
13801	217					208	my $type = ref $obj;
13802	217	100 50	67			445	if ($type eq 'Network') {
13803	132	100				191	if ($obj->{is_aggregate}) {
13804	17					40	return $obj->{networks};
13805							}
13806							else {
13807	115					299	return [ $obj ];
13808							}
13809							}
13810							elsif ($type eq 'Subnet' or $type eq 'Interface') {
13811	85					237	return [ $obj->{network} ];
13812							}
13813							else {
13814	0					0	internal_err("unexpected $obj->{name}");
13815							}
13816							}
13817
13818							sub prepare_nat_commands {
13819	226	100		226	0	274	return if fast_mode();
13820	155					221	progress('Preparing NAT commands');
13821
13822							# Caching for performance.
13823	155					125	my %obj2zone;
13824							my %obj2networks;
13825
13826							# Traverse the topology once for each pair of
13827							# src-(zone/router), dst-(zone/router)
13828	0					0	my %zone2zone2info;
13829	155 155 155					136 184 223	for my $rule (@{ $expanded_rules{permit} }, @{ $expanded_rules{supernet} })
13830							{
13831							next
13832	414	100	50			661	if $rule->{deleted}
13833							and
13834							(not $rule->{managed_intf} or $rule->{deleted}->{managed_intf});
13835	409 409					335 486	my ($src, $dst) = @{$rule}{qw(src dst)};
13836	409		67			997	my $from = $obj2zone{$src} \|\|= get_zone3($src);
13837	409		67			907	my $to = $obj2zone{$dst} \|\|= get_zone3($dst);
13838	409					700	my $info = $zone2zone2info{$from}->{$to};
13839	409	100				569	if (!$info) {
13840	244					435	path_walk($rule, \&collect_nat_path, 'Router');
13841	244					434	$info->{nat_path} = delete $rule->{nat_path};
13842	244					493	$zone2zone2info{$from}->{$to} = $info;
13843							}
13844
13845							# Collect networks only if path has some NAT device.
13846	409	100				808	if ($info->{nat_path}) {
13847	177		67			459	my $src_networks = $obj2networks{$src} \|\|= get_networks($src);
13848	177 177					183 339	@{$info->{src_net}}{@$src_networks} = @$src_networks;
13849	177		67			418	my $dst_networks = $obj2networks{$dst} \|\|= get_networks($dst);
13850	177 177					161 524	@{$info->{dst_net}}{@$dst_networks} = @$dst_networks;
13851							}
13852							}
13853	155					269	for my $hash (values %zone2zone2info) {
13854	196					307	for my $info (values %$hash) {
13855	244	100				529	my $nat_path = $info->{nat_path} or next;
13856	99 99					87 186	my $src_net = [ values %{ $info->{src_net} } ];
13857	99 99					93 166	my $dst_net = [ values %{ $info->{dst_net} } ];
13858	99					133	for my $pair (@$nat_path) {
13859	122					175	distribute_nat_to_device($pair, $src_net, $dst_net);
13860							}
13861							}
13862							}
13863	155					568	return;
13864							}
13865
13866							########################################################################
13867							# Routing
13868							########################################################################
13869
13870							# Get networks for routing.
13871							# Add largest supernet inside the zone, if available.
13872							# This is needed, because we use the supernet in
13873							# secondary optimization too.
13874							# Moreover this reduces the number of routing entries.
13875							# It isn't sufficient to solely use the supernet because network and supernet
13876							# can have different next hops at end of path.
13877							# For an aggregate, take all matching networks inside the zone.
13878							# These are supernets by design.
13879
13880							sub get_route_networks {
13881	927			927	0	731	my ($obj) = @_;
13882	927					818	my $type = ref $obj;
13883	927	100 50	67			1644	if ($type eq 'Network') {
13884	640	100 100				1103	if ($obj->{is_aggregate}) {
13885	82 82					63 158	return @{ $obj->{networks} };
13886							}
13887							elsif (my $max = $obj->{max_routing_net}) {
13888	11					23	return ($max, $obj);
13889							}
13890							else {
13891	547					754	return $obj;
13892							}
13893							}
13894							elsif ($type eq 'Subnet' or $type eq 'Interface') {
13895	287					270	my $net = $obj->{network};
13896	287	100				379	if (my $max = $net->{max_routing_net}) {
13897	28					56	return ($max, $net);
13898							}
13899							else {
13900	259					402	return $net;
13901							}
13902							}
13903							else {
13904	0					0	internal_err("unexpected $obj->{name}");
13905							}
13906							}
13907
13908							# Set up data structure to find routing info inside a security zone.
13909							# Some definitions:
13910							# - Border interfaces are directly attached to the security zone.
13911							# - Border networks are located inside the security zone and are attached
13912							# to border interfaces.
13913							# - All interfaces of border networks, which are not border interfaces,
13914							# are called hop interfaces, because they are used as next hop from
13915							# border interfaces.
13916							# - A cluster is a maximal set of connected networks of the security zone,
13917							# which is surrounded by hop interfaces. A cluster can be empty.
13918							# For each border interface I and each network N inside the security zone
13919							# we need to find the hop interface H via which N is reached from I.
13920							# This is stored in an attribute {route_in_zone} of I.
13921							sub set_routes_in_zone {
13922	658			658	0	561	my ($zone) = @_;
13923
13924							# Mark border networks and hop interfaces.
13925	658					452	my %border_networks;
13926							my %hop_interfaces;
13927	658 658					502 811	for my $in_interface (@{ $zone->{interfaces} }) {
13928	887	100				1276	next if $in_interface->{main_interface};
13929	845					730	my $network = $in_interface->{network};
13930	845	100				1949	next if $border_networks{$network};
13931	670					886	$border_networks{$network} = $network;
13932	670 670					496 766	for my $out_interface (@{ $network->{interfaces} }) {
13933	1006	100				2248	next if $out_interface->{zone};
13934	119	100				183	next if $out_interface->{main_interface};
13935	117					242	$hop_interfaces{$out_interface} = $out_interface;
13936							}
13937							}
13938	658	100				1602	return if not keys %hop_interfaces;
13939	93					75	my %hop2cluster;
13940							my %cluster2borders;
13941	0					0	my $set_cluster;
13942							$set_cluster = sub {
13943	131			131		129	my ($router, $in_intf, $cluster) = @_;
13944	131	100				218	return if $router->{active_path};
13945	124					163	local $router->{active_path} = 1;
13946	124 124					96 170	for my $interface (@{ $router->{interfaces} }) {
13947	307	100				449	next if $interface->{main_interface};
13948	295	100				517	if ($hop_interfaces{$interface}) {
13949	117					177	$hop2cluster{$interface} = $cluster;
13950	117					111	my $network = $interface->{network};
13951	117					246	$cluster2borders{$cluster}->{$network} = $network;
13952	117					248	next;
13953							}
13954	178	100				384	next if $interface eq $in_intf;
13955	150					138	my $network = $interface->{network};
13956	150	100				242	next if $cluster->{$network};
13957	143					191	$cluster->{$network} = $network;
13958	143 143					113 175	for my $out_intf (@{ $network->{interfaces} }) {
13959	188	100				524	next if $out_intf eq $interface;
13960	45	100				71	next if $out_intf->{main_interface};
13961	35					96	$set_cluster->($out_intf->{router}, $out_intf, $cluster);
13962							}
13963							}
13964	93					328	};
13965	93					140	for my $interface (values %hop_interfaces) {
13966	117	100				234	next if $hop2cluster{$interface};
13967	96					98	my $cluster = {};
13968	96					159	$set_cluster->($interface->{router}, $interface, $cluster);
13969
13970							# debug("Cluster: $interface->{name} ",
13971							# join ',', map {$_->{name}} values %$cluster);
13972							}
13973
13974							# Find all networks located behind a hop interface.
13975	93					90	my %hop2networks;
13976							my $set_networks_behind;
13977							$set_networks_behind = sub {
13978	124			124		130	my ($hop, $in_border) = @_;
13979	124	100				222	return if $hop2networks{$hop};
13980	117					149	my $cluster = $hop2cluster{$hop};
13981
13982							# Add networks of directly attached cluster to result.
13983	117					198	my @result = values %$cluster;
13984	117					185	$hop2networks{$hop} = \@result;
13985
13986	117 117					106 231	for my $border (values %{ $cluster2borders{$cluster} }) {
13987	155	100				384	next if $border eq $in_border;
13988
13989							# Add other border networks to result.
13990	38					49	push @result, $border;
13991	38 38					33 46	for my $out_hop (@{ $border->{interfaces} }) {
13992	83	100				169	next if not $hop_interfaces{$out_hop};
13993	45	100				175	next if $hop2cluster{$out_hop} eq $cluster;
13994	7					13	$set_networks_behind->($out_hop, $border);
13995
13996							# Add networks from clusters located behind
13997							# other border networks.
13998	7 7					6 16	push @result, @{ $hop2networks{$out_hop} };
13999							}
14000							}
14001	117					177	$hop2networks{$hop} = [ unique @result];
14002							# debug("Hop: $hop->{name} ", join ',', map {$_->{name}} @result);
14003	93					321	};
14004	93					134	for my $border (values %border_networks) {
14005	111					96	my @border_intf;
14006							my @hop_intf;
14007	111 111					92 142	for my $interface (@{ $border->{interfaces} }) {
14008	233	100				346	next if $interface->{main_interface};
14009	231	100				293	if ($interface->{zone}) {
14010	114					149	push @border_intf, $interface;
14011							}
14012							else {
14013	117					162	push @hop_intf, $interface;
14014							}
14015							}
14016	111					124	for my $hop (@hop_intf) {
14017	117					154	$set_networks_behind->($hop, $border);
14018	117					147	for my $interface (@border_intf) {
14019	120 120					99 197	for my $network (@{ $hop2networks{$hop} }) {
14020
14021							# $border will be found accidently, if clusters
14022							# form a loop inside zone.
14023	205	100				369	next if $network eq $border;
14024	201 201					156 710	push @{ $interface->{route_in_zone}->{$network} }, $hop;
14025							}
14026							}
14027							}
14028							}
14029	93					212	return;
14030							}
14031
14032							# A security zone is entered at $in_intf and exited at $out_intf.
14033							# Find the hop H to reach $out_intf from $in_intf.
14034							# Add routing entries at $in_intf that $dst_networks are reachable via H.
14035							sub add_path_routes {
14036	245			245	0	228	my ($in_intf, $out_intf, $dst_networks) = @_;
14037	245	100				439	return if $in_intf->{routing};
14038	149					153	my $out_net = $out_intf->{network};
14039	149		100			497	my $hops = $in_intf->{route_in_zone}->{$out_net} \|\| [$out_intf];
14040	149					175	for my $hop (@$hops) {
14041	151					253	$in_intf->{hop}->{$hop} = $hop;
14042	151					155	for my $network (@$dst_networks) {
14043
14044							# debug("$in_intf->{name} -> $hop->{name}: $network->{name}");
14045	155					514	$in_intf->{routes}->{$hop}->{$network} = $network;
14046							}
14047							}
14048	149					250	return;
14049							}
14050
14051							# A security zone is entered at $interface.
14052							# $dst_networks are located inside the security zone.
14053							# For each element N of $dst_networks find the next hop H to reach N.
14054							# Add routing entries at $interface that N is reachable via H.
14055							sub add_end_routes {
14056	648			648	0	554	my ($interface, $dst_networks) = @_;
14057	648	100				1231	return if $interface->{routing};
14058	481					442	my $intf_net = $interface->{network};
14059	481					394	my $route_in_zone = $interface->{route_in_zone};
14060	481					471	for my $network (@$dst_networks) {
14061	542	100				1273	next if $network eq $intf_net;
14062	186	50				395	my $hops = $route_in_zone->{$network}
14063							or internal_err("Missing route for $network->{name}",
14064							" at $interface->{name}");
14065	186					172	for my $hop (@$hops) {
14066	192					309	$interface->{hop}->{$hop} = $hop;
14067
14068							# debug("$interface->{name} -> $hop->{name}: $network->{name}");
14069	192					593	$interface->{routes}->{$hop}->{$network} = $network;
14070							}
14071							}
14072	481					1006	return;
14073							}
14074
14075							# This function is called for each zone on the path from src to dst
14076							# of $rule.
14077							# If $in_intf and $out_intf are both defined, packets traverse this zone.
14078							# If $in_intf is not defined, the src is this zone.
14079							# If $out_intf is not defined, dst is this zone;
14080							sub get_route_path {
14081	645			645	0	578	my ($rule, $in_intf, $out_intf) = @_;
14082
14083							# debug("collect: $rule->{src}->{name} -> $rule->{dst}->{name}");
14084							# my $info = '';
14085							# $info .= $in_intf->{name} if $in_intf;
14086							# $info .= ' -> ';
14087							# $info .= $out_intf->{name} if $out_intf;
14088							# debug($info);
14089
14090	645	100 100	100			1699	if ($in_intf and $out_intf) {
14091	112 112					78 243	push @{ $rule->{path} }, [ $in_intf, $out_intf ];
14092							}
14093							elsif (not $in_intf) {
14094	266 266					206 490	push @{ $rule->{path_entries} }, $out_intf;
14095							}
14096							else {
14097	267 267					206 466	push @{ $rule->{path_exits} }, $in_intf;
14098							}
14099	645					728	return;
14100							}
14101
14102							sub check_and_convert_routes;
14103
14104							sub find_active_routes {
14105	226			226	0	311	progress('Finding routes');
14106	226					254	for my $zone (@zones) {
14107	658					798	set_routes_in_zone $zone;
14108							}
14109	226					208	my %routing_tree;
14110	226					382	my $pseudo_prt = { name => '--' };
14111	226 226 226					205 268 311	for my $rule (@{ $expanded_rules{permit} }, @{ $expanded_rules{supernet} })
14112							{
14113	524					643	my ($src, $dst) = ($rule->{src}, $rule->{dst});
14114
14115							# Ignore deleted rules.
14116							# Add the typical check for {managed_intf}
14117							# which covers the destination interface.
14118							# Because we handle both directions at once,
14119							# we would need an attribute {managed_intf}
14120							# for the source interface as well. But this attribute doesn't exist
14121							# and we add an equivalent check for source.
14122	524	50	25			938	if (
14123							$rule->{deleted}
14124							and (not $rule->{managed_intf} or $rule->{deleted}->{managed_intf})
14125							and (
14126							not(is_interface $src and ($src->{router}->{managed} or
14127							$src->{router}->{routing_only}))
14128							or (is_interface $rule->{deleted}->{src}
14129							and ($rule->{deleted}->{src}->{router}->{managed} or
14130							$rule->{deleted}->{src}->{router}->{routing_only}))
14131							)
14132							)
14133							{
14134	20					26	next;
14135							}
14136	504					626	my $src_zone = get_zone2 $src;
14137	504					575	my $dst_zone = get_zone2 $dst;
14138
14139							# Source interface is located in security zone of destination or
14140							# destination interface is located in security zone of source.
14141							# path_walk will do nothing.
14142	504	100				1025	if ($src_zone eq $dst_zone) {
14143	98					105	for my $from ($src, $dst) {
14144	196	100				325	my $to = $from eq $src ? $dst : $src;
14145	196	100				220	next if not is_interface($from);
14146	170	100				311	next if not $from->{zone};
14147	115		67			313	$from = $from->{main_interface} \|\| $from;
14148	115					143	my @networks = get_route_networks($to);
14149	115					146	add_end_routes($from, \@networks);
14150							}
14151	98					138	next;
14152							}
14153	406					297	my $pseudo_rule;
14154	406	100 100				1182	if ($pseudo_rule = $routing_tree{$src_zone}->{$dst_zone}) {
14155							}
14156							elsif ($pseudo_rule = $routing_tree{$dst_zone}->{$src_zone}) {
14157	13					22	($src, $dst) = ($dst, $src);
14158	13					17	($src_zone, $dst_zone) = ($dst_zone, $src_zone);
14159							}
14160							else {
14161	246					491	$pseudo_rule = {
14162							src => $src_zone,
14163							dst => $dst_zone,
14164							prt => $pseudo_prt,
14165							};
14166	246					476	$routing_tree{$src_zone}->{$dst_zone} = $pseudo_rule;
14167							}
14168	406					511	my @src_networks = get_route_networks($src);
14169	406					449	for my $network (@src_networks) {
14170	419					1005	$pseudo_rule->{src_networks}->{$network} = $network;
14171							}
14172	406					495	my @dst_networks = get_route_networks($dst);
14173	406					439	for my $network (@dst_networks) {
14174	413					951	$pseudo_rule->{dst_networks}->{$network} = $network;
14175							}
14176	406	100	50			522	if (is_interface($src) && ($src->{router}->{managed} \|\|
14177							$src->{router}->{routing_only}))
14178							{
14179	17		67			52	$src = $src->{main_interface} \|\| $src;
14180	17					32	$pseudo_rule->{src_interfaces}->{$src} = $src;
14181	17					22	for my $network (@dst_networks) {
14182	17					49	$pseudo_rule->{src_intf2nets}->{$src}->{$network} = $network;
14183							}
14184							}
14185	406	100	50			496	if (is_interface($dst) && ($dst->{router}->{managed} \|\|
14186							$dst->{router}->{routing_only}))
14187							{
14188	37		67			141	$dst = $dst->{main_interface} \|\| $dst;
14189	37					73	$pseudo_rule->{dst_interfaces}->{$dst} = $dst;
14190	37					43	for my $network (@src_networks) {
14191	36					165	$pseudo_rule->{dst_intf2nets}->{$dst}->{$network} = $network;
14192							}
14193							}
14194							}
14195	226					382	for my $href (values %routing_tree) {
14196	426					745	for my $pseudo_rule (values %$href) {
14197	246					410	path_walk($pseudo_rule, \&get_route_path, 'Zone');
14198	246 246					212 498	my $src_networks = [ values %{ $pseudo_rule->{src_networks} } ];
14199	246 246					218 423	my $dst_networks = [ values %{ $pseudo_rule->{dst_networks} } ];
14200	246 246					204 489	my @src_interfaces = values %{ $pseudo_rule->{src_interfaces} };
14201	246 246					195 372	my @dst_interfaces = values %{ $pseudo_rule->{dst_interfaces} };
14202	246 246					195 389	for my $tuple (@{ $pseudo_rule->{path} }) {
14203	112					116	my ($in_intf, $out_intf) = @$tuple;
14204	112					157	add_path_routes($in_intf, $out_intf, $dst_networks);
14205	112					184	add_path_routes($out_intf, $in_intf, $src_networks);
14206							}
14207	246 246					222 304	for my $entry (@{ $pseudo_rule->{path_entries} }) {
14208	266					284	for my $src_intf (@src_interfaces) {
14209	19	100				57	next if $src_intf->{router} eq $entry->{router};
14210	8	50				17	if (my $redun_intf = $src_intf->{redundancy_interfaces}) {
14211	0 0	0				0 0	if (grep { $_->{router} eq $entry->{router} }
14212							@$redun_intf)
14213							{
14214	0					0	next;
14215							}
14216							}
14217	8					28	my $intf_nets = [
14218	8					6	values %{ $pseudo_rule->{src_intf2nets}->{$src_intf} }
14219							];
14220	8					12	add_path_routes($src_intf, $entry, $intf_nets);
14221							}
14222	266					366	add_end_routes($entry, $src_networks);
14223							}
14224	246 246					225 339	for my $exit (@{ $pseudo_rule->{path_exits} }) {
14225	267					278	for my $dst_intf (@dst_interfaces) {
14226	45	100				130	next if $dst_intf->{router} eq $exit->{router};
14227	19	100				41	if (my $redun_intf = $dst_intf->{redundancy_interfaces}) {
14228	6 12	50				7 31	if (grep { $_->{router} eq $exit->{router} }
14229							@$redun_intf)
14230							{
14231	6					9	next;
14232							}
14233							}
14234	13					35	my $intf_nets = [
14235	13					13	values %{ $pseudo_rule->{dst_intf2nets}->{$dst_intf} }
14236							];
14237	13					23	add_path_routes($dst_intf, $exit, $intf_nets);
14238							}
14239	267					303	add_end_routes($exit, $dst_networks);
14240							}
14241							}
14242							}
14243	226					343	check_and_convert_routes;
14244	226					954	return;
14245							}
14246
14247							# Parameters:
14248							# - a bridged interface without an IP address, not usable as hop.
14249							# - the network for which the hop was found.
14250							# Result:
14251							# - one or more layer 3 interfaces, usable as hop.
14252							# Non optimized version.
14253							# Doesn't matter as long we have only a few bridged networks
14254							# or don't use static routing at the border of bridged networks.
14255							sub fix_bridged_hops;
14256
14257							sub fix_bridged_hops {
14258	2			2	0	2	my ($hop, $network) = @_;
14259	2					2	my @result;
14260	2					3	my $router = $hop->{router};
14261	2 2					2 2	for my $interface (@{ $router->{interfaces} }) {
14262	6	100				12	next if $interface eq $hop;
14263	4					17	HOP:
14264	4					3	for my $hop2 (values %{ $interface->{hop} }) {
14265	1 1					1 3	for my $network2 (values %{ $interface->{routes}->{$hop2} }) {
14266	1	50				3	if ($network eq $network2) {
14267	1	50				3	if ($hop2->{ip} eq 'bridge') {
14268	0					0	push @result, fix_bridged_hops($hop2, $network);
14269							}
14270							else {
14271	1					1	push @result, $hop2;
14272							}
14273	1					3	next HOP;
14274							}
14275							}
14276							}
14277							}
14278	2					7	return @result;
14279							}
14280
14281							sub check_and_convert_routes {
14282	226			226	0	286	progress('Checking for duplicate routes');
14283
14284							# Fix routes to bridged interfaces without IP address.
14285	226					268	for my $router (@managed_routers, @routing_only_routers) {
14286	365 365					290 459	for my $interface (@{ $router->{interfaces} }) {
14287	862	100				1731	next if not $interface->{network}->{bridged};
14288	16 16					11 35	for my $hop (values %{ $interface->{hop} }) {
14289	8	100				20	next if $hop->{ip} ne 'bridged';
14290	2 2					3 6	for my $network (values %{ $interface->{routes}->{$hop} }) {
14291	2					3	my @real_hop = fix_bridged_hops($hop, $network);
14292	2					4	for my $rhop (@real_hop) {
14293	1					2	$interface->{hop}->{$rhop} = $rhop;
14294	1					4	$interface->{routes}->{$rhop}->{$network} = $network;
14295							}
14296							}
14297	2					4	delete $interface->{hop}->{$hop};
14298	2					7	delete $interface->{routes}->{$hop};
14299							}
14300							}
14301							}
14302
14303	226					282	for my $router (@managed_routers, @routing_only_routers) {
14304
14305							# Adjust routes through VPN tunnel to cleartext interface.
14306	365 365					297 454	for my $interface (@{ $router->{interfaces} }) {
14307	862	100				1935	next if not $interface->{ip} eq 'tunnel';
14308	21					17	my $tunnel_routes = $interface->{routes};
14309	21					36	$interface->{routes} = $interface->{hop} = {};
14310	21					26	my $real_intf = $interface->{real_interface};
14311	21	50				31	next if $real_intf->{routing};
14312	21					17	my $real_net = $real_intf->{network};
14313	21 21					17 25	for my $peer (@{ $interface->{peers} }) {
14314	21					20	my $real_peer = $peer->{real_interface};
14315	21					21	my $peer_net = $real_peer->{network};
14316
14317							# Find hop to peer network and add tunnel networks to this hop.
14318	21					17	my @hops;
14319
14320							# Peer network is directly connected.
14321	21	50 50				1013	if ($real_net eq $peer_net) {
14322	0	0				0	if ($real_peer->{ip} !~ /^(?:short\|negotiated)$/) {
14323	0					0	push @hops, $real_peer;
14324							}
14325							else {
14326	0					0	err_msg("$real_peer->{name} used to reach",
14327							" software clients\n",
14328							" must not be directly connected to",
14329							" $real_intf->{name}\n",
14330							" Connect it to some network behind next hop");
14331	0					0	next;
14332							}
14333							}
14334
14335							# Peer network is located in directly connected zone.
14336							elsif ($real_net->{zone} eq $peer_net->{zone}) {
14337	21					19	my $route_in_zone = $real_intf->{route_in_zone};
14338	21	50				39	my $hops = $route_in_zone->{$peer_net} or
14339							internal_err("Missing route for $peer_net->{name}",
14340							" at $real_intf->{name} ");
14341	21					28	push @hops, @$hops;
14342							}
14343
14344							# Find path to peer network to determine available hops.
14345							else {
14346	0					0	my $pseudo_rule = {
14347							src => $real_intf,
14348							dst => $peer_net,
14349							action => '--',
14350							prt => { name => '--' },
14351							};
14352	0					0	my @zone_hops;
14353							my $walk = sub {
14354	0			0		0	my ($rule, $in_intf, $out_intf) = @_;
14355	0	0				0	$in_intf or internal_err("No in_intf");
14356	0	0				0	$in_intf eq $real_intf or return;
14357	0	0				0	$out_intf or internal_err("No out_intf");
14358	0	0				0	$out_intf->{network} or internal_err "No out net";
14359	0					0	push @zone_hops, $out_intf;
14360	0					0	};
14361	0					0	path_walk($pseudo_rule, $walk, 'Zone');
14362	0					0	my $route_in_zone = $real_intf->{route_in_zone};
14363	0					0	for my $hop (@zone_hops) {
14364
14365	0					0	my $hop_net = $hop->{network};
14366	0	0				0	if ($hop_net eq $real_net) {
14367	0					0	push @hops, $hop;
14368							}
14369							else {
14370	0	0				0	my $hops = $route_in_zone->{$hop_net} or
14371							internal_err("Missing route for $hop_net->{name}",
14372							" at $real_intf->{name}");
14373	0					0	push @hops, @$hops;
14374							}
14375							}
14376							}
14377
14378	21					17	my $hop_routes;
14379	21 2	50 100	80			76 6	if ( @hops > 1
14380							&& equal(map({ $_->{redundancy_interfaces} \|\| $_ }
14381							@hops))
14382							\|\| @hops == 1)
14383							{
14384	20					18	my $hop = shift @hops;
14385	20		100			51	$hop_routes = $real_intf->{routes}->{$hop} \|\|= {};
14386	20					32	$real_intf->{hop}->{$hop} = $hop;
14387							# debug "Use $hop->{name} as hop for $real_peer->{name}";
14388							}
14389							else {
14390
14391							# This can only happen for vpn software clients.
14392							# For hardware clients the route is known
14393							# for the encrypted traffic which is allowed
14394							# by gen_tunnel_rules (even for negotiated interface).
14395	1					2	my $count = @hops;
14396	2					6	my $names = join ('',
14397	1					1	map({ "\n - $_->{name}" }
14398							@hops));
14399	1					11	err_msg(
14400							"Can't determine next hop to reach $peer_net->{name}",
14401							" while moving routes\n",
14402							" of $interface->{name} to $real_intf->{name}.\n",
14403							" Exactly one route is needed,",
14404							" but $count candidates were found:",
14405							$names);
14406							}
14407
14408							# Use found hop to reach tunneled networks in $tunnel_routes.
14409	21					39	for my $tunnel_net_hash (values %$tunnel_routes) {
14410	17					26	for my $tunnel_net (values %$tunnel_net_hash) {
14411	23					48	$hop_routes->{$tunnel_net} = $tunnel_net;
14412							}
14413							}
14414
14415							# Add route to reach peer interface.
14416	21	50				44	if ($peer_net ne $real_net) {
14417	21					83	$hop_routes->{$peer_net} = $peer_net;
14418							}
14419							}
14420							}
14421
14422							# Remember, via which local interface a network is reached.
14423	365					320	my %net2intf;
14424
14425	365 365					289 439	for my $interface (@{ $router->{interfaces} }) {
14426
14427							# Remember, via which remote interface a network is reached.
14428	862					640	my %net2hop;
14429
14430							# Remember, via which remote redundancy interfaces a network
14431							# is reached. We use this to check, if alle members of a group
14432							# of redundancy interfaces are used to reach the network.
14433							# Otherwise it would be wrong to route to the virtual interface.
14434							my %net2group;
14435
14436	862	100	100			1874	next if $interface->{loop} and $interface->{routing};
14437	757	100				1096	next if $interface->{ip} eq 'bridged';
14438	743 743					574 1854	for my $hop (sort by_name values %{ $interface->{hop} }) {
14439	150 150					143 418	for my $network (sort by_name
14440							values %{ $interface->{routes}->{$hop} })
14441							{
14442	226	100				382	if (my $interface2 = $net2intf{$network}) {
14443	11	50				28	if ($interface2 ne $interface) {
14444
14445							# Network is reached via two different
14446							# local interfaces. Show warning if static
14447							# routing is enabled for both interfaces.
14448	0	0	0			0	if ( not $interface->{routing}
14449							and not $interface2->{routing})
14450							{
14451	0					0	warn_msg (
14452							"Two static routes for $network->{name}\n",
14453							" via $interface->{name} and",
14454							" $interface2->{name}"
14455							);
14456							}
14457							}
14458							}
14459							else {
14460	215					288	$net2intf{$network} = $interface;
14461							}
14462	226	50				374	unless ($interface->{routing}) {
14463	226					199	my $group = $hop->{redundancy_interfaces};
14464	226	100				312	if ($group) {
14465	16 16					13 28	push @{ $net2group{$network} }, $hop;
14466							}
14467	226	100				329	if (my $hop2 = $net2hop{$network}) {
14468
14469							# Network is reached via two different hops.
14470							# Check if both belong to same group
14471							# of redundancy interfaces.
14472	11					12	my $group2 = $hop2->{redundancy_interfaces};
14473	11	100	50			50	if ($group && $group2 && $group eq $group2) {
14474
14475							# Prevent multiple identical routes to
14476							# different interfaces
14477							# with identical virtual IP.
14478	8					29	delete $interface->{routes}->{$hop}->{$network};
14479							}
14480							else {
14481	3					26	warn_msg (
14482							"Two static routes for $network->{name}\n",
14483							" at $interface->{name}",
14484							" via $hop->{name} and $hop2->{name}"
14485							);
14486							}
14487							}
14488							else {
14489	215					510	$net2hop{$network} = $hop;
14490							}
14491							}
14492							}
14493							}
14494	743					1131	for my $net_ref (keys %net2group) {
14495	8					8	my $hops = $net2group{$net_ref};
14496	8					8	my $hop1 = $hops->[0];
14497	8 8	100				7 17	next if @$hops == @{ $hop1->{redundancy_interfaces} };
14498	2					4	my $network = $interface->{routes}->{$hop1}->{$net_ref};
14499
14500							# A network is routed to a single physical interface.
14501							# It is probably a loopback interface of the same device.
14502							# Move hop from virtual to physical interface.
14503	2	100	67			10	if (@$hops == 1 && (my $phys_hop = $hop1->{orig_main})) {
14504	1					2	delete $interface->{routes}->{$hop1}->{$net_ref};
14505	1					2	$interface->{routes}->{$phys_hop}->{$network} = $network;
14506	1					3	$interface->{hop}->{$phys_hop} = $phys_hop;
14507							}
14508							else {
14509
14510							# This occurs if different redundancy groups use
14511							# parts of of a group of routers.
14512							# More than 3 virtual interfaces together with
14513							# pathrestrictions have already been rejected.
14514	1					4	err_msg(
14515							"$network->{name} is reached via $hop1->{name}\n",
14516							" but not via all related redundancy interfaces"
14517							);
14518							}
14519							}
14520
14521							# Convert to array, because hash isn't needed any longer.
14522							# Array is sorted to get deterministic output.
14523	743					2202	$interface->{hop} =
14524	743					619	[ sort by_name values %{ $interface->{hop} } ];
14525							}
14526							}
14527	226					237	return;
14528							}
14529
14530							sub ios_route_code;
14531							sub prefix_code;
14532							sub full_prefix_code;
14533							sub address;
14534
14535							sub print_header {
14536	529			529	0	489	my ($router, $what) = @_;
14537	529					559	my $comment_char = $router->{model}->{comment_char};
14538	529	100				747	my $where = $router->{vrf_members} ? " for $router->{name}" : '';
14539	529					980	print "$comment_char [ $what$where ]\n";
14540	529					595	return;
14541							}
14542
14543							sub print_routes {
14544	252			252	0	226	my ($router) = @_;
14545	252					254	my $model = $router->{model};
14546	252					264	my $type = $model->{routing};
14547	252					241	my $vrf = $router->{vrf};
14548	252					231	my $comment_char = $model->{comment_char};
14549	252					267	my $do_auto_default_route = $config{auto_default_route};
14550	252		100			517	my $crypto_type = $model->{crypto} \|\| '';
14551	252					211	my %intf2hop2nets;
14552							my @interfaces;
14553	0					0	my %mask2ip2net;
14554	0					0	my %net2hop_info;
14555	0					0	my %net2no_opt;
14556	252 252					217 358	for my $interface (@{ $router->{interfaces} }) {
14557	620	100				962	next if $interface->{ip} eq 'bridged';
14558	610	100				866	if ($interface->{routing}) {
14559	182					137	$do_auto_default_route = 0;
14560	182					220	next;
14561							}
14562
14563	428					371	push @interfaces, $interface;
14564
14565							# ASA with site-to-site VPN needs individual routes for each peer.
14566	428	100	100			743	if ($interface->{hub} && $crypto_type eq 'ASA') {
14567	5					5	$do_auto_default_route = 0;
14568							}
14569	428					352	my $no_nat_set = $interface->{no_nat_set};
14570
14571	428 428					333 704	for my $hop (@{ $interface->{hop} }) {
14572	117					161	my $hop_info = [ $interface, $hop ];
14573
14574							# A hash having all networks reachable via current hop
14575							# both as key and as value.
14576	117					200	my $net_hash = $interface->{routes}->{$hop};
14577	117					183	for my $network (values %$net_hash) {
14578	175					271	my $nat_network = get_nat_network($network, $no_nat_set);
14579	175 175					154 251	my ($ip, $mask) = @{$nat_network}{ 'ip', 'mask' };
14580	175	100	67			341	if ($ip == 0 and $mask == 0) {
14581	10					10	$do_auto_default_route = 0;
14582							}
14583
14584							# Implicitly overwrite duplicate networks.
14585	175					1240	$mask2ip2net{$mask}->{$ip} = $nat_network;
14586	175					521	$net2hop_info{$nat_network} = $hop_info;
14587							}
14588							}
14589							}
14590	252	100				633	return if not @interfaces;
14591
14592							# Find and remove duplicate networks.
14593							# Go from smaller to larger networks.
14594	179					374	for my $mask (reverse sort keys %mask2ip2net) {
14595	131					335	NETWORK:
14596	131					120	for my $ip (sort numerically keys %{ $mask2ip2net{$mask} }) {
14597	170					178	my $small = $mask2ip2net{$mask}->{$ip};
14598	170					230	my $hop_info = $net2hop_info{$small};
14599	170					172	my ($interface, $hop) = @$hop_info;
14600
14601							# ASA with site-to-site VPN needs individual routes for each peer.
14602	170	100	100			375	if (!($interface->{hub} && $crypto_type eq 'ASA')) {
14603
14604	154					144	my $m = $mask;
14605	154					126	my $i = $ip;
14606	154					230	while ($m) {
14607
14608							# Clear upper bit, because left shift is undefined
14609							# otherwise.
14610	3443					2488	$m = $m & 0x7fffffff;
14611	3443					2401	$m <<= 1;
14612	3443					2418	$i = $i & $m; # Perl bug #108480.
14613	3443	100				6642	my $ip2net = $mask2ip2net{$m} or next;
14614	44	100				103	my $big = $mask2ip2net{$m}->{$i} or next;
14615
14616							# $small is subnet of $big.
14617							# If both use the same hop, then $small is redundant.
14618	25	100				61	if ($net2hop_info{$big} eq $hop_info) {
14619							# debug "Removed: $small->{name} -> $hop->{name}";
14620	14					40	next NETWORK;
14621							}
14622
14623							# Otherwise $small isn't redundant, even if a bigger network
14624							# with same hop exists.
14625							# It must not be removed by default route later.
14626	11					23	$net2no_opt{$small} = 1;
14627							# debug "No opt: $small->{name} -> $hop->{name}";
14628	11					12	last;
14629							}
14630							}
14631	156 156					116 766	push(@{ $intf2hop2nets{$interface}->{$hop} }, [ $ip, $mask, $small ]);
14632							}
14633							}
14634
14635	179	100				303	if ($do_auto_default_route) {
14636
14637							# Find interface and hop with largest number of routing entries.
14638	162					143	my $max_intf;
14639							my $max_hop;
14640
14641							# Substitute routes to one hop with a default route,
14642							# if there are at least two entries.
14643	162					144	my $max = 1;
14644	162					182	for my $interface (@interfaces) {
14645	382 382					263 577	for my $hop (@{ $interface->{hop} }) {
14646	123 101	100				266 321	my $count = grep({ !$net2no_opt{$_->[2]} }
14647	101					78	@{ $intf2hop2nets{$interface}->{$hop} \|\| [] });
14648	101	100				260	if ($count > $max) {
14649	12					14	$max_intf = $interface;
14650	12					12	$max_hop = $hop;
14651	12					30	$max = $count;
14652							}
14653							}
14654							}
14655	162	100	67			364	if ($max_intf && $max_hop) {
14656
14657							# Use default route for this direction.
14658							# But still generate routes for small networks
14659							# with supernet behind other hop.
14660	37					69	$intf2hop2nets{$max_intf}->{$max_hop} =
14661							[ [ 0, 0 ],
14662	12					26	grep({ $net2no_opt{$_->[2]} }
14663	12					22	@{ $intf2hop2nets{$max_intf}->{$max_hop} })
14664							];
14665							}
14666							}
14667	179					332	print_header($router, 'Routing');
14668
14669	179					151	my $ios_vrf;
14670	179	50 100				356	$ios_vrf = $vrf ? "vrf $vrf " : '' if $type eq 'IOS';
14671	179					165	my $nxos_prefix = '';
14672
14673	179					208	for my $interface (@interfaces) {
14674	428 428					325 644	for my $hop (@{ $interface->{hop} }) {
14675
14676							# For unnumbered and negotiated interfaces use interface name
14677							# as next hop.
14678	117	100				408	my $hop_addr =
14679							$interface->{ip} =~ /^(?:unnumbered\|negotiated\|tunnel)$/
14680							? $interface->{hardware}->{name}
14681							: print_ip $hop->{ip};
14682
14683	117 117					124 291	for my $netinfo (@{ $intf2hop2nets{$interface}->{$hop} }) {
14684	132	50				231	if ($config{comment_routes}) {
14685	0	0				0	if (my $net = $netinfo->[2]) {
14686	0					0	print("$comment_char route",
14687							" $net->{name} -> $hop->{name}\n");
14688							}
14689							}
14690	132	100 100 100 50 0				307	if ($type eq 'IOS') {
14691	39					64	my $adr = ios_route_code($netinfo);
14692	39					174	print "ip route $ios_vrf$adr $hop_addr\n";
14693							}
14694							elsif ($type eq 'NX-OS') {
14695	18	100	100			47	if ($vrf && ! $nxos_prefix) {
14696
14697							# Print "vrf context" only once
14698							# and indent "ip route" commands.
14699	4					10	print "vrf context $vrf\n";
14700	4					5	$nxos_prefix = ' ';
14701							}
14702	18					28	my $adr = full_prefix_code($netinfo);
14703	18					66	print "${nxos_prefix}ip route $adr $hop_addr\n";
14704							}
14705							elsif ($type eq 'PIX') {
14706	60					89	my $adr = ios_route_code($netinfo);
14707	60					350	print
14708							"route $interface->{hardware}->{name} $adr $hop_addr\n";
14709							}
14710							elsif ($type eq 'iproute') {
14711	15					25	my $adr = prefix_code($netinfo);
14712	15					66	print "ip route add $adr via $hop_addr\n";
14713							}
14714							elsif ($type eq 'none') {
14715
14716							# Do nothing.
14717							}
14718							else {
14719	0					0	internal_err("unexpected routing type '$type'");
14720							}
14721							}
14722							}
14723							}
14724	179					760	return;
14725							}
14726
14727							##############################################################################
14728							# NAT commands
14729							##############################################################################
14730
14731							sub print_nat1 {
14732	92			92	0	112	my ($router, $print_dynamic, $print_static_host, $print_static) = @_;
14733	92					101	my $model = $router->{model};
14734	92					94	my $comment_char = $model->{comment_char};
14735
14736	92					142	print_header($router, 'NAT');
14737
14738	131					254	my @hardware =
14739	92 92					83 220	sort { $a->{level} <=> $b->{level} } @{ $router->{hardware} };
14740
14741	92					133	for my $in_hw (@hardware) {
14742	208	100				418	my $src_nat = $in_hw->{src_nat} or next;
14743	17					16	my $in_nat = $in_hw->{no_nat_set};
14744	17					20	for my $out_hw (@hardware) {
14745
14746							# Value is { net => net, .. }
14747	44	100				105	my $net_hash = $src_nat->{$out_hw} or next;
14748	21					19	my $out_nat = $out_hw->{no_nat_set};
14749
14750							# Sorting is only needed for getting output deterministic.
14751							# For equal addresses look at the NAT address.
14752	0	0	0			0	my @networks =
14753							sort {
14754	21					35	$a->{ip} <=> $b->{ip}
14755							\|\| $a->{mask} <=> $b->{mask}
14756							\|\| get_nat_network($a, $out_nat)
14757							->{ip} <=> get_nat_network($b, $out_nat)->{ip}
14758							} values %$net_hash;
14759
14760	21					22	for my $network (@networks) {
14761	21					30	my ($in_ip, $in_mask, $in_dynamic) =
14762	21					21	@{ get_nat_network($network, $in_nat) }{qw(ip mask dynamic)};
14763	21					26	my ($out_ip, $out_mask, $out_dynamic) =
14764	21					24	@{ get_nat_network($network, $out_nat) }{qw(ip mask dynamic)};
14765
14766							# Ignore dynamic translation, which doesn't occur at
14767							# current router
14768	21	50	50			73	if ( $out_dynamic
14769							and $in_dynamic
14770							and $out_dynamic eq $in_dynamic)
14771							{
14772	0					0	$out_dynamic = $in_dynamic = undef;
14773							}
14774
14775							# We are talking about source addresses.
14776	21	100				27	if ($out_dynamic) {
14777
14778							# Check for static NAT entries of hosts and interfaces.
14779	15 15 15					14 21 19	for my $host (@{ $network->{subnets} },
14780							@{ $network->{interfaces} })
14781							{
14782	18	100				51	if (my $out_host_ip = $host->{nat}->{$out_dynamic}) {
14783	3					5	my $pair = address($host, $in_nat);
14784	3					4	my ($in_host_ip, $in_host_mask) = @$pair;
14785	3					6	$print_static_host->(
14786							$in_hw, $in_host_ip, $in_host_mask, $out_hw,
14787							$out_host_ip
14788							);
14789							}
14790							}
14791	15					24	$print_dynamic->(
14792							$in_hw, $in_ip, $in_mask,
14793							$out_hw, $out_ip, $out_mask
14794							);
14795							}
14796							else {
14797	6					10	$print_static->($in_hw, $in_ip, $in_mask, $out_hw, $out_ip);
14798							}
14799							}
14800							}
14801							}
14802	92					150	return;
14803							}
14804
14805							sub print_pix_static {
14806	86			86	0	89	my ($router) = @_;
14807
14808							# Index for linking "global" and "nat" commands.
14809	86					81	my $dyn_index = 1;
14810
14811							# Hash of indexes for reusing of NAT pools.
14812	86					68	my %global2index;
14813
14814							# Hash of indexes for creating only a single "nat" command if mapped at
14815							# different interfaces.
14816							my %nat2index;
14817
14818							my $print_dynamic = sub {
14819	11			11		15	my ($in_hw, $in_ip, $in_mask, $out_hw, $out_ip, $out_mask) = @_;
14820	11					14	my $in_name = $in_hw->{name};
14821	11					11	my $out_name = $out_hw->{name};
14822
14823							# Use a single "global" command if multiple networks are
14824							# mapped to a single pool.
14825	11					28	my $global_index = $global2index{$out_name}->{$out_ip}->{$out_mask};
14826
14827							# Use a single "nat" command if one network is mapped to
14828							# different pools at different interfaces.
14829	11					22	my $nat_index = $nat2index{$in_name}->{$in_ip}->{$in_mask};
14830	11	50	67			28	$global_index and $nat_index and internal_err();
14831
14832	11		67			43	my $index = $global_index \|\| $nat_index \|\| $dyn_index++;
14833	11	100				17	if (not $global_index) {
14834	8					23	$global2index{$out_name}->{$out_ip}->{$out_mask} = $index;
14835	8					8	my $pool;
14836
14837							# global (outside) 1 interface
14838	8					14	my $out_intf_ip = $out_hw->{interfaces}->[0]->{ip};
14839	8	50	33			21	if ($out_ip == $out_intf_ip && $out_mask == 0xffffffff) {
14840	0					0	$pool = 'interface';
14841							}
14842
14843							# global (outside) 1 10.7.6.0-10.7.6.255 netmask 255.255.255.0
14844							# nat (inside) 1 14.4.36.0 255.255.252.0
14845							else {
14846	8					12	my $max = $out_ip \| complement_32bit $out_mask;
14847	8					13	my $mask = print_ip $out_mask;
14848	8	100				19	my $range =
14849							($out_ip == $max)
14850							? print_ip($out_ip)
14851							: print_ip($out_ip) . '-' . print_ip($max);
14852	8					17	$pool = "$range netmask $mask";
14853							}
14854	8					36	print "global ($out_name) $index $pool\n";
14855							}
14856
14857	11	100				27	if (not $nat_index) {
14858	9					25	$nat2index{$in_name}->{$in_ip}->{$in_mask} = $index;
14859	9					12	my $in = print_ip $in_ip;
14860	9					12	my $mask = print_ip $in_mask;
14861	9					41	print "nat ($in_name) $index $in $mask";
14862	9	100				23	print " outside" if $in_hw->{level} < $out_hw->{level};
14863	9					32	print "\n";
14864							}
14865	86					414	};
14866							my $print_static_host = sub {
14867	2			2		6	my ($in_hw, $in_host_ip, $in_host_mask, $out_hw, $out_host_ip) = @_;
14868	2					2	my $in_name = $in_hw->{name};
14869	2					4	my $out_name = $out_hw->{name};
14870	2					2	my $in = print_ip $in_host_ip;
14871	2					3	my $mask = print_ip $in_host_mask;
14872	2					3	my $out = print_ip $out_host_ip;
14873	2					20	print "static ($in_name,$out_name) $out $in netmask $mask\n";
14874	86					226	};
14875							my $print_static = sub {
14876	6			6		8	my ($in_hw, $in_ip, $in_mask, $out_hw, $out_ip) = @_;
14877	6	50	50			37	if ( $in_hw->{level} > $out_hw->{level}
14878							\|\| $in_hw->{need_identity_nat}
14879							\|\| $in_ip != $out_ip)
14880							{
14881	6					7	my $in_name = $in_hw->{name};
14882	6					5	my $out_name = $out_hw->{name};
14883	6					9	my $in = print_ip $in_ip;
14884	6					8	my $out = print_ip $out_ip;
14885	6					8	my $mask = print_ip $in_mask;
14886
14887							# static (inside,outside) \
14888							# 10.111.0.0 111.0.0.0 netmask 255.255.252.0
14889	6					57	print "static ($in_name,$out_name) $out $in netmask $mask\n";
14890							}
14891	86					236	};
14892	86					142	print_nat1($router, $print_dynamic, $print_static_host, $print_static);
14893	86 86					73 116	for my $in_hw (@{ $router->{hardware} }) {
14894	194	50				348	next if not $in_hw->{need_nat_0};
14895	0					0	print "nat ($in_hw->{name}) 0 0.0.0.0 0.0.0.0\n";
14896							}
14897	86					2268	return;
14898							}
14899
14900							sub print_asa_nat {
14901	6			6	0	7	my ($router) = @_;
14902
14903							# Hash for re-using object definitions.
14904	6					6	my %objects;
14905
14906							my $subnet_obj = sub {
14907	6			6		6	my ($ip, $mask) = @_;
14908	6					12	my $p_ip = print_ip($ip);
14909	6					8	my $p_mask = print_ip($mask);
14910	6					12	my $name = "${p_ip}_${p_mask}";
14911	6	100				10	if (not $objects{$name}) {
14912	4					9	print "object network $name\n";
14913	4					6	print " subnet $p_ip $p_mask\n";
14914	4					7	$objects{$name} = $name;
14915							}
14916	6					9	return $name;
14917	6					25	};
14918							my $range_obj = sub {
14919	4			4		6	my ($ip, $mask) = @_;
14920	4					4	my $max = $ip \| complement_32bit $mask;
14921	4					4	my $p_ip = print_ip($ip);
14922	4					4	my $name = $p_ip;
14923	4					3	my $sub_cmd;
14924	4	100				6	if ($ip == $max) {
14925	2					3	$sub_cmd = "host $p_ip";
14926							}
14927							else {
14928	2					3	my $p_max = print_ip($max);
14929	2					4	$name .= "-$p_max";
14930	2					3	$sub_cmd = "range $p_ip $p_max";
14931							}
14932	4	100				9	if (not $objects{$name}) {
14933	3					6	print "object network $name\n";
14934	3					5	print " $sub_cmd\n";
14935	3					4	$objects{$name} = $name;
14936							}
14937	4					5	return $name;
14938	6					23	};
14939
14940							my $print_dynamic = sub {
14941	4			4		6	my ($in_hw, $in_ip, $in_mask, $out_hw, $out_ip, $out_mask) = @_;
14942	4					4	my $in_name = $in_hw->{name};
14943	4					5	my $out_name = $out_hw->{name};
14944	4					5	my $in_obj = $subnet_obj->($in_ip, $in_mask);
14945	4					3	my $out_obj;
14946
14947							# NAT to interface
14948	4					4	my $out_intf_ip = $out_hw->{interfaces}->[0]->{ip};
14949	4	50	33			10	if ($out_ip == $out_intf_ip && $out_mask == 0xffffffff) {
14950	0					0	$out_obj = 'interface';
14951							}
14952							else {
14953	4					4	$out_obj = $range_obj->($out_ip, $out_mask);
14954							}
14955	4					28	print("nat ($in_name,$out_name) source dynamic $in_obj $out_obj\n");
14956	6					20	};
14957							my $print_static_host = sub {
14958	1			1		1	my ($in_hw, $in_host_ip, $in_host_mask, $out_hw, $out_host_ip) = @_;
14959	1					2	my $in_name = $in_hw->{name};
14960	1					1	my $out_name = $out_hw->{name};
14961	1					2	my $in_host_obj = $subnet_obj->($in_host_ip, $in_host_mask);
14962	1					2	my $out_host_obj = $subnet_obj->($out_host_ip, $in_host_mask);
14963
14964							# Print with line number 1 because static host NAT must be
14965							# inserted in front of dynamic network NAT.
14966	1					6	print("nat ($in_name,$out_name) 1 source static",
14967							" $in_host_obj $out_host_obj\n");
14968	6					25	};
14969							my $print_static = sub {
14970	0			0		0	my ($in_hw, $in_ip, $in_mask, $out_hw, $out_ip) = @_;
14971	0					0	my $in_name = $in_hw->{name};
14972	0					0	my $out_name = $out_hw->{name};
14973	0					0	my $in_obj = $subnet_obj->($in_ip, $in_mask);
14974	0					0	my $out_obj = $subnet_obj->($out_ip, $in_mask);
14975	0					0	print("nat ($in_name,$out_name) source static $in_obj $out_obj\n");
14976	6					21	};
14977	6					11	print_nat1($router, $print_dynamic, $print_static_host, $print_static);
14978	6					103	return;
14979							}
14980
14981							sub optimize_nat_networks {
14982	92			92	0	95	my ($router) = @_;
14983	92 92					88 154	my @hardware = @{ $router->{hardware} };
14984	92					120	for my $in_hw (@hardware) {
14985	208	100				397	my $src_nat = $in_hw->{src_nat} or next;
14986	17					17	my $in_nat = $in_hw->{no_nat_set};
14987	17					18	for my $out_hw (@hardware) {
14988
14989							# Value is { net => net, .. }
14990	44	100				108	my $net_hash = $src_nat->{$out_hw} or next;
14991	21					21	my $out_nat = $out_hw->{no_nat_set};
14992
14993							# Prevent duplicate entries from different networks
14994							# translated to one identical address.
14995	21					23	my @has_indentical;
14996	21					37	for my $network (values %$net_hash) {
14997	21	100				51	my $identical = $network->{is_identical} or next;
14998	3					5	my $in = $identical->{$in_nat};
14999	3					3	my $out = $identical->{$out_nat};
15000	3	0	25			10	if ($in && $out && $in eq $out) {
15001	0					0	push @has_indentical, $network;
15002							}
15003							}
15004	21					26	for my $network (@has_indentical) {
15005	0					0	delete $net_hash->{$network};
15006	0					0	my $one_net = $network->{is_identical}->{$out_nat};
15007	0					0	$net_hash->{$one_net} = $one_net;
15008							}
15009
15010							# Remove redundant networks.
15011							# A network is redundant if some enclosing network is found
15012							# in both NAT domains of incoming and outgoing interface.
15013	21					32	for my $network (values %$net_hash) {
15014	21					29	my $net = $network->{is_in}->{$out_nat};
15015	21					59	while ($net) {
15016	3					3	my $net2;
15017	3	50	25			10	if ( $net_hash->{$net}
15018							and $net2 = $network->{is_in}->{$in_nat}
15019							and $net_hash->{$net2})
15020							{
15021	0					0	delete $net_hash->{$network};
15022	0					0	last;
15023							}
15024							else {
15025	3					10	$net = $net->{is_in}->{$out_nat};
15026							}
15027							}
15028							}
15029							}
15030							}
15031	92					123	return;
15032							}
15033
15034							sub print_nat {
15035	248			248	0	211	my ($router) = @_;
15036	248					252	my $model = $router->{model};
15037
15038							# NAT commands not implemented for other models.
15039	248	100				560	return if not $model->{has_interface_level};
15040
15041	92					156	optimize_nat_networks($router);
15042	92	100				145	if ($model->{v8_4}) {
15043
15044	6					14	print_asa_nat($router);
15045							}
15046							else {
15047	86					137	print_pix_static($router);
15048							}
15049	92					177	return;
15050							}
15051
15052							##############################################################################
15053							# Distributing rules to managed devices
15054							##############################################################################
15055
15056							sub distribute_rule {
15057	702			702	0	630	my ($rule, $in_intf, $out_intf) = @_;
15058
15059							# Traffic from src reaches this router via in_intf
15060							# and leaves it via out_intf.
15061							# in_intf is undefined if src is an interface of current router.
15062							# out_intf is undefined if dst is an interface of current router.
15063							# Outgoing packets from a router itself are never filtered.
15064	702	100				977	return unless $in_intf;
15065	647					601	my $router = $in_intf->{router};
15066	647	100				1024	return if not $router->{managed};
15067	625					541	my $model = $router->{model};
15068
15069							# Rules of type stateless must only be processed at
15070							# - stateless routers or
15071							# - routers which are stateless for packets destined for
15072							# their own interfaces or
15073							# - stateless tunnel interfaces of ASA-VPN.
15074	625	100				909	if ($rule->{stateless}) {
15075	78	100	50			177	if (
15076							not( $model->{stateless}
15077							or not $out_intf and $model->{stateless_self})
15078							)
15079							{
15080	17					25	return;
15081							}
15082							}
15083
15084							# Rules of type stateless_icmp must only be processed at routers
15085							# which don't handle stateless_icmp automatically;
15086	608	50	33			1037	return if $rule->{stateless_icmp} and not $model->{stateless_icmp};
15087
15088	608					498	my $dst = $rule->{dst};
15089	608					514	my $intf_hash = $router->{crosslink_intf_hash};
15090
15091							# Rule to managed interface must be processed
15092							# - at the corresponding router or
15093							# - at the edge of a cluster of crosslinked routers
15094							# even if the rule is marked as deleted,
15095							# because code for interface is placed separately into {intf_rules}.
15096	608	100				855	if ($rule->{deleted}) {
15097
15098							# We are at an intermediate router.
15099	1	50	33 0			3	return if $out_intf and (!$intf_hash \|\| !$intf_hash->{$dst});
15100
15101							# No code needed if it is deleted by another rule to the same interface.
15102	1	50				2	return if $rule->{deleted}->{managed_intf};
15103							}
15104
15105							# Don't generate code for src any:[interface:r.loopback] at router:r.
15106	608	50				838	return if $in_intf->{loopback};
15107
15108							# Adapt rule to dynamic NAT.
15109	608	50				930	if (my $dynamic_nat = $rule->{dynamic_nat}) {
15110	0					0	my $no_nat_set = $in_intf->{no_nat_set};
15111	0					0	my $orig_rule = $rule;
15112	0					0	for my $where (split(/,/, $dynamic_nat)) {
15113	0					0	my $obj = $rule->{$where};
15114	0					0	my $network = $obj->{network};
15115	0					0	my $nat_network = get_nat_network($network, $no_nat_set);
15116	0	0				0	next if $nat_network eq $network;
15117	0	0				0	my $nat_tag = $nat_network->{dynamic} or next;
15118
15119							# Ignore object with static translation.
15120	0	0				0	next if $obj->{nat}->{$nat_tag};
15121
15122							# Otherwise, filtering occurs at other router, therefore
15123							# the whole network can pass here.
15124							# But attention, this assumption only holds, if the other
15125							# router filters fully. Hence disable optimization of
15126							# secondary rules.
15127	0					0	delete $orig_rule->{some_non_secondary};
15128	0					0	delete $orig_rule->{some_primary};
15129
15130							# Permit whole network, because no static address is known.
15131							# Make a copy of current rule, because the original rule
15132							# must not be changed.
15133	0					0	$rule = { %$rule, $where => $network };
15134							}
15135							}
15136
15137	608					447	my $key;
15138
15139							# Packets for the router itself or for some interface of a
15140							# crosslinked cluster of routers (only IOS, NX-OS with "need_protect").
15141	608	100 100	75			1814	if (!$out_intf \|\| $intf_hash && $intf_hash->{$dst}) {
15142
15143							# Packets for the router itself. For PIX we can only reach that
15144							# interface, where traffic enters the PIX.
15145	121	100				211	if ($model->{filter} eq 'PIX') {
15146	32	100 100 50	67			96	if ($dst eq $in_intf) {
15147							}
15148							elsif ($dst eq $network_00 or $dst eq $in_intf->{network}) {
15149
15150							# Ignore rule, because generated code would permit traffic
15151							# to cleartext interface as well.
15152	8	50				16	return if $in_intf->{ip} eq 'tunnel';
15153
15154							# Change destination in $rule to interface.
15155							# Make a copy of current rule, because the
15156							# original rule must not be changed.
15157	8					18	$rule = {%$rule};
15158	8					14	$rule->{dst} = $in_intf;
15159							}
15160
15161							# Permit management access through tunnel.
15162							# On ASA device use command "management-access".
15163							# Permit management access through bridged interface.
15164							elsif ($in_intf->{ip} =~ /^(?:tunnel\|bridged)/) {
15165							}
15166
15167							# Silently ignore everything else.
15168							else {
15169	0					0	return;
15170							}
15171							}
15172	121					115	$key = 'intf_rules';
15173							}
15174							elsif ($out_intf->{hardware}->{need_out_acl}) {
15175	9					9	$key = 'out_rules';
15176	9	100				22	if (not $in_intf->{hardware}->{no_in_acl}) {
15177	2 2					2 9	push @{ $in_intf->{hardware}->{rules} }, $rule;
15178							}
15179							}
15180							else {
15181	478					440	$key = 'rules';
15182							}
15183
15184	608	100 100 100	100			2049	if ($in_intf->{ip} eq 'tunnel') {
15185
15186							# Rules for single software clients are stored individually.
15187							# Consistency checks have already been done at expand_crypto.
15188							# Rules are needed at tunnel for generating split tunnel ACL
15189							# regardless of $router->{no_crypto_filter} value.
15190	39	100				58	if (my $id2rules = $in_intf->{id_rules}) {
15191	22					20	my $src = $rule->{src};
15192	22	50 0				25	if (is_subnet $src) {
15193	22	50				33	my $id = $src->{id}
15194							or internal_err("$src->{name} must have ID");
15195	22	50				42	my $id_intf = $id2rules->{$id}
15196							or internal_err("No entry for $id at id_rules");
15197	22 22					15 33	push @{ $id_intf->{$key} }, $rule;
15198							}
15199							elsif (is_network $src) {
15200	0	0				0	$src->{has_id_hosts}
15201							or internal_err("$src->{name} must have ID-hosts\n ",
15202							print_rule $rule);
15203	0 0 0					0 0 0	for my $id (map { $_->{id} } @{ $src->{hosts} }) {
15204	0 0					0 0	push @{ $id2rules->{$id}->{$key} }, $rule;
15205							}
15206							}
15207							else {
15208	0					0	internal_err(
15209							"Expected host or network as src but got $src->{name}\n ",
15210							print_rule $rule);
15211							}
15212							}
15213
15214	39	100				63	if ($router->{no_crypto_filter}) {
15215	36 36					25 57	push @{ $in_intf->{real_interface}->{hardware}->{$key} }, $rule;
15216							}
15217
15218							# Rules are needed at tunnel for generating detailed_crypto_acl.
15219	39	100				61	if (not $in_intf->{id_rules}) {
15220	17 17					13 24	push @{ $in_intf->{$key} }, $rule;
15221							}
15222							}
15223							elsif ($key eq 'out_rules') {
15224	9 9					8 16	push @{ $out_intf->{hardware}->{$key} }, $rule;
15225							}
15226
15227							# Remember outgoing interface.
15228							elsif ($key eq 'rules' and $model->{has_io_acl}) {
15229	63 63					49 141	push @{ $in_intf->{hardware}->{io_rules}
15230							->{ $out_intf->{hardware}->{name} } }, $rule;
15231							}
15232							else {
15233	497 497					377 789	push @{ $in_intf->{hardware}->{$key} }, $rule;
15234							}
15235	608					883	return;
15236							}
15237
15238							my $permit_any_rule;
15239
15240							sub add_router_acls {
15241	155			155	0	203	for my $router (@managed_routers) {
15242	257					269	my $has_io_acl = $router->{model}->{has_io_acl};
15243	257 257					208 324	for my $hardware (@{ $router->{hardware} }) {
15244
15245							# Some managed devices are connected by a crosslink network.
15246							# Permit any traffic at the internal crosslink interface.
15247	559	100				820	if ($hardware->{crosslink}) {
15248
15249							# We can savely change rules at hardware interface
15250							# because it has been checked that no other logical
15251							# networks are attached to the same hardware.
15252							#
15253							# Substitute rules for each outgoing interface.
15254	10	50				15	if ($has_io_acl) {
15255	0 0					0 0	for my $rules (values %{ $hardware->{io_rules} }) {
15256	0					0	$rules = [$permit_any_rule];
15257							}
15258							}
15259							else {
15260	10					16	$hardware->{rules} = [$permit_any_rule];
15261	10	50				16	if ($hardware->{need_out_acl}) {
15262	0					0	$hardware->{out_rules} = [$permit_any_rule];
15263							}
15264							}
15265	10					18	$hardware->{intf_rules} = [$permit_any_rule];
15266	10					13	next;
15267							}
15268
15269	549 549					389 636	for my $interface (@{ $hardware->{interfaces} }) {
15270
15271							# Current router is used as default router even for
15272							# some internal networks.
15273	600	50				843	if ($interface->{reroute_permit}) {
15274	0 0					0 0	for my $net (@{ $interface->{reroute_permit} }) {
15275
15276							# Prepend to all other rules.
15277	0	0				0	unshift(
15278							@{
15279	0					0	$has_io_acl
15280
15281							# Incoming and outgoing interface are equal.
15282							? $hardware->{io_rules}->{ $hardware->{name} }
15283							: $hardware->{rules}
15284							},
15285							{
15286							src => $network_00,
15287							dst => $net,
15288							prt => $prt_ip
15289							}
15290							);
15291							}
15292							}
15293
15294							# Is dynamic routing used?
15295	600	100				878	if (my $routing = $interface->{routing}) {
15296	182	100				457	if($routing->{name} !~ /^(?:manual\|dynamic)$/) {
15297	1					1	my $prt = $routing->{prt};
15298	1	50				3	if (my $dst_range = $prt->{dst_range}) {
15299	0					0	$prt = $dst_range;
15300							}
15301	1					1	my $network = $interface->{network};
15302
15303							# Permit multicast packets from current network.
15304	1 1					1 2	for my $mcast (@{ $routing->{mcast} }) {
15305	2 2					2 4	push @{ $hardware->{intf_rules} },
15306							{
15307							src => $network,
15308							dst => $mcast,
15309							prt => $prt
15310							};
15311	2					4	$ref2obj{$mcast} = $mcast;
15312							}
15313							# Additionally permit unicast packets.
15314							# We use the network address as destination
15315							# instead of the interface address,
15316							# because we get fewer rules if the interface has
15317							# multiple addresses.
15318	1 1					2 3	push @{ $hardware->{intf_rules} },
15319							{
15320							src => $network,
15321							dst => $network,
15322							prt => $prt
15323							};
15324							}
15325							}
15326
15327							# Handle multicast packets of redundancy protocols.
15328	600	100				836	if (my $type = $interface->{redundancy_type}) {
15329	14					14	my $network = $interface->{network};
15330	14					18	my $mcast = $xxrp_info{$type}->{mcast};
15331	14					16	my $prt = $xxrp_info{$type}->{prt};
15332	14	100				19	if (my $dst_range = $prt->{dst_range}) {
15333	2					2	$prt = $dst_range;
15334							}
15335	14 14					11 30	push @{ $hardware->{intf_rules} },
15336							{
15337							src => $network,
15338							dst => $mcast,
15339							prt => $prt
15340							};
15341	14					26	$ref2obj{$mcast} = $mcast;
15342							}
15343
15344							# Handle DHCP requests.
15345	600	100				1503	if ($interface->{dhcp_server}) {
15346	1 1					1 5	push @{ $hardware->{intf_rules} },
15347							{
15348							src => $network_00,
15349							dst => $network_00,
15350							prt => $prt_bootps->{dst_range}
15351							};
15352							}
15353							}
15354							}
15355							}
15356	155					158	return;
15357							}
15358
15359							# At least for $prt_esp and $prt_ah the ACL lines need to have a fixed order.
15360							# Otherwise,
15361							# - if the device is accessed over an IPSec tunnel
15362							# - and we change the ACL incrementally,
15363							# the connection may be lost.
15364							sub cmp_address {
15365	36			36	0	28	my ($obj) = @_;
15366	36					29	my $type = ref $obj;
15367	36	50 50	33			106	if ($type eq 'Network' or $type eq 'Subnet') {
15368	0					0	return "$obj->{ip},$obj->{mask}";
15369							}
15370							elsif ($type eq 'Interface') {
15371	36					93	return("$obj->{ip}," . 0xffffffff); ## no critic (MismatchedOperators)
15372							}
15373							else {
15374	0					0	internal_err();
15375							}
15376							}
15377
15378							sub distribute_rules {
15379	24			24	0	24	my ($rules, $in_intf, $out_intf) = @_;
15380	24					25	for my $rule (@$rules) {
15381	36					45	distribute_rule($rule, $in_intf, $out_intf);
15382							}
15383	24					40	return;
15384							}
15385
15386							sub create_general_permit_rules {
15387	9			9	0	10	my ($protocols, $context) = @_;
15388	9					9	my @rules;
15389	9					13	for my $prt (@$protocols) {
15390
15391							# Prevent modification of original array.
15392	13					12	my $prt = $prt;
15393	13	100 100				34	if (ref $prt eq 'ARRAY') {
15394	2					3	(my $src_range, $prt, my $orig_prt) = @$prt;
15395							}
15396							elsif (my $main_prt = $prt->{main}) {
15397	2					2	$prt = $main_prt;
15398							}
15399	13					26	my $rule = {
15400							src => $network_00,
15401							dst => $network_00,
15402							prt => $prt,
15403							};
15404	13					20	push @rules, $rule;
15405							}
15406	9					17	return \@rules;
15407							}
15408
15409							sub distribute_general_permit {
15410	155			155	0	184	for my $router (@managed_routers) {
15411	257	100				549	my $general_permit = $router->{general_permit} or next;
15412	9					26	my $rules =
15413							create_general_permit_rules(
15414							$general_permit, "general_permit of $router->{name}");
15415	9					12	my $need_protect = $router->{need_protect};
15416	9 9					10 10	for my $in_intf (@{ $router->{interfaces} }) {
15417	16	50				29	next if $in_intf->{main_interface};
15418
15419							# At VPN hub, don't permit any -> any, but only traffic
15420							# from each encrypted network.
15421	16	100				25	if ($in_intf->{is_hub}) {
15422	3					3	my $id_rules = $in_intf->{id_rules};
15423	3 5	100				6 7	for my $src (
15424							$id_rules
15425	1					2	? map({ $_->{src} } values %$id_rules)
15426							: @{ $in_intf->{peer_networks} }
15427							)
15428							{
15429	7					8	for my $rule (@$rules) {
15430	7					13	my $rule = {%$rule};
15431	7					8	$rule->{src} = $src;
15432	7 7					7 7	for my $out_intf (@{ $router->{interfaces} }) {
15433	14	100				45	next if $out_intf eq $in_intf;
15434	7	50				12	next if $out_intf->{ip} eq 'tunnel';
15435
15436							# Traffic traverses the device.
15437							# Traffic for the device itself isn't needed
15438							# at VPN hub.
15439	7					7	distribute_rule($rule, $in_intf, $out_intf);
15440							}
15441							}
15442							}
15443							}
15444							else {
15445	13 13					12 18	for my $out_intf (@{ $router->{interfaces} }) {
15446	26	100				55	next if $out_intf eq $in_intf;
15447
15448							# For IOS and NX-OS print this rule only
15449							# once at interface filter rules below
15450							# (for incoming ACL).
15451	13	100				20	if ($need_protect) {
15452	2					3	my $out_hw = $out_intf->{hardware};
15453
15454							# For interface with outgoing ACLs
15455							# we need to add the rule.
15456							# distribute_rule would add rule to incoming,
15457							# hence we add rule directly to outgoing rules.
15458	2	50				3	if ($out_hw->{need_out_acl}) {
15459	0 0					0 0	push @{ $out_hw->{out_rules} }, @$rules;
15460							}
15461	2					3	next;
15462							}
15463	11	50				17	next if $out_intf->{main_interface};
15464
15465							# Traffic traverses the device.
15466	11					16	distribute_rules($rules, $in_intf, $out_intf);
15467							}
15468
15469							# Traffic for the device itself.
15470	13	50				24	next if $in_intf->{ip} eq 'bridged';
15471	13					18	distribute_rules($rules, $in_intf, undef);
15472							}
15473							}
15474							}
15475	155					150	return;
15476							}
15477
15478							sub sort_rules_by_prio {
15479
15480							# Sort rules by reverse priority of protocol.
15481							# This should be done late to get all auxiliary rules processed.
15482	155			155	0	209	for my $type ('deny', 'supernet', 'permit') {
15483	534	100	100 25			3709	$expanded_rules{$type} = [
15484							sort {
15485	465					977	($b->{prt}->{prio} \|\| 0) <=> ($a->{prt}->{prio} \|\| 0)
15486							\|\| ($a->{prt}->{prio} \|\| 0)
15487							&& ( cmp_address($a->{src}) cmp cmp_address($b->{src})
15488							\|\| cmp_address($a->{dst}) cmp cmp_address($b->{dst}))
15489	465					343	} @{ $expanded_rules{$type} }
15490							];
15491							}
15492	155					156	return;
15493							}
15494
15495							sub rules_distribution {
15496	208	100		208	0	248	return if fast_mode();
15497	155					234	progress('Distributing rules');
15498
15499	155					216	sort_rules_by_prio();
15500
15501							# Deny rules
15502	155 155					141 234	for my $rule (@{ $expanded_rules{deny} }) {
15503	0	0				0	next if $rule->{deleted};
15504	0					0	path_walk($rule, \&distribute_rule);
15505							}
15506
15507							# Handle global permit after deny rules.
15508	155					254	distribute_general_permit();
15509
15510							# Permit rules
15511	155 155 155					132 184 209	for my $rule (@{ $expanded_rules{supernet} }, @{ $expanded_rules{permit} })
15512							{
15513							next
15514	474	100	50			767	if $rule->{deleted}
15515							and
15516							(not $rule->{managed_intf} or $rule->{deleted}->{managed_intf});
15517	458					677	path_walk($rule, \&distribute_rule, 'Router');
15518							}
15519
15520	155					252	add_router_acls();
15521	155					269	prepare_local_optimization();
15522
15523							# No longer needed, free some memory.
15524	155					279	%expanded_rules = ();
15525	155					207	%obj2path = ();
15526	155					162	%key2obj = ();
15527	155					130	return;
15528							}
15529
15530							##############################################################################
15531							# ACL Generation
15532							##############################################################################
15533
15534							# Returns [ ip, mask ] pair
15535							sub address {
15536	2817			2817	0	2315	my ($obj, $no_nat_set) = @_;
15537	2817					2586	my $type = ref $obj;
15538	2817	100 100 100 50				3848	if ($type eq 'Network') {
15539	2168					2382	$obj = get_nat_network($obj, $no_nat_set);
15540
15541							# ToDo: Is it OK to permit a dynamic address as destination?
15542	2168	50				2917	if ($obj->{ip} eq 'unnumbered') {
15543	0					0	internal_err("Unexpected unnumbered $obj->{name}");
15544							}
15545							else {
15546	2168					4488	return [ $obj->{ip}, $obj->{mask} ];
15547							}
15548							}
15549							elsif ($type eq 'Subnet') {
15550	96					141	my $network = get_nat_network($obj->{network}, $no_nat_set);
15551	96	100				146	if (my $nat_tag = $network->{dynamic}) {
15552	2	50				5	if (my $ip = $obj->{nat}->{$nat_tag}) {
15553
15554							# Single static NAT IP for this host.
15555	2					4	return [ $ip, 0xffffffff ];
15556							}
15557							else {
15558
15559							# This has been converted to the whole network before,
15560							# and hence should never happen.
15561	0					0	return [ $network->{ip}, $network->{mask} ];
15562							}
15563							}
15564							else {
15565
15566							# Take higher bits from network NAT, lower bits from original IP.
15567							# This works with and without NAT.
15568	94					158	my $ip =
15569							$network->{ip} \| $obj->{ip} & complement_32bit $network->{mask};
15570	94					210	return [ $ip, $obj->{mask} ];
15571							}
15572							}
15573							elsif ($type eq 'Interface') {
15574	516	50				1099	if ($obj->{ip} =~ /^(unnumbered\|short)$/) {
15575	0					0	internal_err("Unexpected $obj->{ip} $obj->{name}");
15576							}
15577
15578	516					673	my $network = get_nat_network($obj->{network}, $no_nat_set);
15579
15580	516	100 100				1054	if ($obj->{ip} eq 'negotiated') {
15581	2 2					1 4	my ($network_ip, $network_mask) = @{$network}{ 'ip', 'mask' };
15582	2					4	return [ $network_ip, $network_mask ];
15583							}
15584							elsif (my $nat_tag = $network->{dynamic}) {
15585	4	100				12	if (my $ip = $obj->{nat}->{$nat_tag}) {
15586
15587							# Single static NAT IP for this interface.
15588	3					7	return [ $ip, 0xffffffff ];
15589							}
15590							else {
15591
15592							# Should never happen.
15593							# aborts with error in mark_dynamic_nat_rules.
15594	1					3	return [ $network->{ip}, $network->{mask} ];
15595							}
15596							}
15597							else {
15598
15599							# Take higher bits from network NAT, lower bits from original IP.
15600							# This works with and without NAT.
15601	510					785	my $ip =
15602							$network->{ip} \| $obj->{ip} & complement_32bit $network->{mask};
15603	510					1048	return [ $ip, 0xffffffff ];
15604							}
15605							}
15606							elsif ($type eq 'Objectgroup') {
15607	37					56	return $obj;
15608							}
15609							else {
15610	0					0	my $type = ref $obj;
15611	0					0	internal_err("Unexpected object of type '$type'");
15612							}
15613							}
15614
15615							# Given an IP and mask, return its address in Cisco syntax.
15616							sub cisco_acl_addr {
15617	2086			2086	0	1753	my ($pair, $model) = @_;
15618	2086	100 100 100				2240	if (is_objectgroup $pair) {
15619	37	100				68	my $keyword =
15620							$model->{filter} eq 'NX-OS' ? 'addrgroup' : 'object-group';
15621	37					94	return "$keyword $pair->{name}";
15622							}
15623							elsif ($pair->[0] == 0) {
15624	1199					1722	return "any";
15625							}
15626							elsif ($model->{use_prefix}) {
15627	51					62	return full_prefix_code($pair);
15628							}
15629							else {
15630	799					795	my ($ip, $mask) = @$pair;
15631	799					889	my $ip_code = print_ip($ip);
15632	799	100				1083	if ($mask == 0xffffffff) {
15633	289					564	return "host $ip_code";
15634							}
15635							else {
15636	510	100				947	$mask = complement_32bit($mask) if $model->{inversed_acl_mask};
15637	510					559	my $mask_code = print_ip($mask);
15638	510					1149	return "$ip_code $mask_code";
15639							}
15640							}
15641							}
15642
15643							sub ios_route_code {
15644	99			99	0	97	my ($pair) = @_;
15645	99					120	my ($ip, $mask) = @$pair;
15646	99					118	my $ip_code = print_ip($ip);
15647	99					130	my $mask_code = print_ip($mask);
15648	99					198	return "$ip_code $mask_code";
15649							}
15650
15651							# Given an IP and mask, return its address
15652							# as "x.x.x.x/x" or "x.x.x.x" if prefix == 32.
15653							sub prefix_code {
15654	163			163	0	149	my ($pair) = @_;
15655	163					157	my ($ip, $mask) = @$pair;
15656	163					234	my $ip_code = print_ip($ip);
15657	163					1102	my $prefix_code = mask2prefix($mask);
15658	163	100				463	return $prefix_code == 32 ? $ip_code : "$ip_code/$prefix_code";
15659							}
15660
15661							sub full_prefix_code {
15662	69			69	0	65	my ($pair) = @_;
15663	69					73	my ($ip, $mask) = @$pair;
15664	69					79	my $ip_code = print_ip($ip);
15665	69					84	my $prefix_code = mask2prefix($mask);
15666	69					163	return "$ip_code/$prefix_code";
15667							}
15668
15669							# Returns 3 values for building a Cisco ACL:
15670							# permit <val1> <src> <val2> <dst> <val3>
15671							sub cisco_prt_code {
15672	995			995	0	916	my ($src_range, $prt, $model) = @_;
15673	995					1038	my $proto = $prt->{proto};
15674
15675	995	100 100 100	100			1667	if ($proto eq 'ip') {
15676	709					1127	return ('ip', undef, undef);
15677							}
15678							elsif ($proto eq 'tcp' or $proto eq 'udp') {
15679							my $port_code = sub {
15680	266			266		251	my ($range_obj) = @_;
15681	266 266					217 462	my ($v1, $v2) = @{ $range_obj->{range} };
15682	266	100 100 50 50	67			526	if ($v1 == $v2) {
15683	213					451	return ("eq $v1");
15684							}
15685							elsif ($v1 == 1 and $v2 == 65535) {
15686	44					61	return (undef);
15687							}
15688							elsif ($v2 == 65535) {
15689	0					0	return 'gt ' . ($v1 - 1);
15690							}
15691							elsif ($v1 == 1) {
15692	0					0	return 'lt ' . ($v2 + 1);
15693							}
15694							else {
15695	9					28	return ("range $v1 $v2");
15696							}
15697	253					811	};
15698	253					1265	my $dst_prt = $port_code->($prt);
15699	253	100				461	if (my $established = $prt->{established}) {
15700	33	50				48	if (defined $dst_prt) {
15701	0					0	$dst_prt .= ' established';
15702							}
15703							else {
15704	33					41	$dst_prt = 'established';
15705							}
15706							}
15707	253		67			372	my $src_prt = $src_range && $port_code->($src_range);
15708	253					1310	return ($proto, $src_prt, $dst_prt);
15709							}
15710							elsif ($proto eq 'icmp') {
15711	28	100				47	if (defined(my $type = $prt->{type})) {
15712	24	50				42	if (defined(my $code = $prt->{code})) {
15713	0	0				0	if ($model->{no_filter_icmp_code}) {
15714
15715							# PIX can't handle the ICMP code field.
15716							# If we try to permit e.g. "port unreachable",
15717							# "unreachable any" could pass the PIX.
15718	0					0	return ($proto, undef, $type);
15719							}
15720							else {
15721	0					0	return ($proto, undef, "$type $code");
15722							}
15723							}
15724							else {
15725	24					61	return ($proto, undef, $type);
15726							}
15727							}
15728							else {
15729	4					9	return ($proto, undef, undef);
15730							}
15731							}
15732							else {
15733	5					10	return ($proto, undef, undef);
15734							}
15735							}
15736
15737							# Returns iptables code for filtering a protocol.
15738							sub iptables_prt_code {
15739	89			89	0	79	my ($src_range, $prt) = @_;
15740	89					91	my $proto = $prt->{proto};
15741
15742	89	50 100 100	100			270	if ($proto eq 'ip') {
15743	0					0	return '';
15744							}
15745							elsif ($proto eq 'tcp' or $proto eq 'udp') {
15746							my $port_code = sub {
15747	54			54		50	my ($range_obj) = @_;
15748	54 54					44 94	my ($v1, $v2) = @{ $range_obj->{range} };
15749	54	100 100 50 50	67			141	if ($v1 == $v2) {
15750	26					38	return $v1;
15751							}
15752							elsif ($v1 == 1 and $v2 == 65535) {
15753	9					16	return '';
15754							}
15755							elsif ($v2 == 65535) {
15756	0					0	return "$v1:";
15757							}
15758							elsif ($v1 == 1) {
15759	0					0	return ":$v2";
15760							}
15761							else {
15762	19					44	return "$v1:$v2";
15763							}
15764	51					153	};
15765	51					67	my $result = "-p $proto";
15766	51		67			76	my $sport = $src_range && $port_code->($src_range);
15767	51	50				68	$result .= " --sport $sport" if $sport;
15768	51					62	my $dport = $port_code->($prt);
15769	51	100				122	$result .= " --dport $dport" if $dport;
15770	51					237	return $result;
15771							}
15772							elsif ($proto eq 'icmp') {
15773	30	100				48	if (defined(my $type = $prt->{type})) {
15774	22	50				28	if (defined(my $code = $prt->{code})) {
15775	0					0	return "-p $proto --icmp-type $type/$code";
15776							}
15777							else {
15778	22					57	return "-p $proto --icmp-type $type";
15779							}
15780							}
15781							else {
15782	8					18	return "-p $proto";
15783							}
15784							}
15785							else {
15786	8					18	return "-p $proto";
15787							}
15788							}
15789
15790							sub cisco_acl_line {
15791	506			506	0	584	my ($router, $rules_aref, $no_nat_set, $prefix) = @_;
15792	506					479	my $model = $router->{model};
15793	506					479	my $filter_type = $model->{filter};
15794	506	50				2623	$filter_type =~ /^(:?IOS\|NX-OS\|PIX\|ACE)$/
15795							or internal_err("Unknown filter_type $filter_type");
15796	506					424	my $numbered = 10;
15797	506					491	my $active_log = $router->{log};
15798	506					562	for my $rule (@$rules_aref) {
15799	995	50				1518	print "$model->{comment_char} " . print_rule($rule) . "\n"
15800							if $config{comment_acls};
15801	995					1681	my ($deny, $src, $dst, $src_range, $prt) =
15802	995					816	@{$rule}{qw(deny src dst src_range prt)};
15803	995	100				1284	my $action = $deny ? 'deny' : 'permit';
15804	995					1276	my $spair = address($src, $no_nat_set);
15805	995					1198	my $dpair = address($dst, $no_nat_set);
15806
15807	995					1302	my ($proto_code, $src_port_code, $dst_port_code) =
15808							cisco_prt_code($src_range, $prt, $model);
15809	995					2043	my $result = "$prefix $action $proto_code";
15810	995					1346	$result .= ' ' . cisco_acl_addr($spair, $model);
15811	995	100				1669	$result .= " $src_port_code" if defined $src_port_code;
15812	995					1136	$result .= ' ' . cisco_acl_addr($dpair, $model);
15813	995	100				1686	$result .= " $dst_port_code" if defined $dst_port_code;
15814
15815							# Find code for logging.
15816	995					729	my $log_code;
15817	995	100	100			1676	if ($active_log && (my $log = $rule->{log})) {
15818	20					22	for my $tag (@$log) {
15819	20	100				33	if (exists $active_log->{$tag}) {
15820	18	100				30	if (my $modifier = $active_log->{$tag}) {
15821	16					21	my $normalized = $model->{log_modifiers}->{$modifier};
15822	16	100				21	if ($normalized eq ':subst') {
15823	5					7	$log_code = $modifier;
15824							}
15825							else {
15826	11					16	$log_code = "log $normalized";
15827							}
15828							}
15829							else {
15830	2					3	$log_code = 'log';
15831							}
15832
15833							# Take first of possibly several matching tags.
15834	18					20	last;
15835							}
15836							}
15837							}
15838	995	100 100	100			2712	if ($log_code) {
15839	18					27	$result .= " $log_code";
15840							}
15841							elsif ($router->{log_deny} && $deny) {
15842	2					3	$result .= " log";
15843							}
15844
15845							# Add line numbers.
15846	995	100				1356	if ($filter_type eq 'NX-OS') {
15847	62					83	$result = " $numbered$result";
15848	62					63	$numbered += 10;
15849							}
15850	995					2885	print "$result\n";
15851							}
15852	506					648	return;
15853							}
15854
15855							my $min_object_group_size = 2;
15856
15857							sub find_object_groups {
15858	250			250	0	241	my ($router, $hardware) = @_;
15859	250					249	my $model = $router->{model};
15860	250					246	my $filter_type = $model->{filter};
15861	250					221	my $active_log = $router->{log};
15862	250	100				333	my $keyword = $filter_type eq 'NX-OS'
15863							? 'object-group ip address'
15864							: 'object-group network';
15865
15866							# Find identical groups of same size.
15867	250		100			627	my $size2first2group_hash = ($router->{size2first2group_hash} \|\|= {});
15868	250		100			725	$router->{vrf_shared_data}->{obj_group_counter} \|\|= 0;
15869
15870							# Leave 'intf_rules' untouched, because they are handled
15871							# indivually for ASA, PIX.
15872							# NX-OS needs them indivually when optimizing need_protect.
15873	250					280	for my $rule_type ('rules', 'out_rules') {
15874	500	100				862	next if not $hardware->{$rule_type};
15875
15876							# Find object-groups in src / dst of rules.
15877	499					494	for my $this ('src', 'dst') {
15878	998	100				1378	my $that = $this eq 'src' ? 'dst' : 'src';
15879	998					717	my %group_rule_tree;
15880
15881							# Find groups of rules with identical
15882							# deny, src_range, prt, log, src/dst and different dst/src.
15883	998 998					734 1385	for my $rule (@{ $hardware->{$rule_type} }) {
15884	549		100			1293	my $deny = $rule->{deny} \|\| '';
15885	549					502	my $that = $rule->{$that};
15886	549					490	my $this = $rule->{$this};
15887	549		50			1202	my $src_range = $rule->{src_range} \|\| '';
15888	549					454	my $prt = $rule->{prt};
15889	549					1258	my $key = "$deny,$that,$src_range,$prt";
15890	549	100				828	if (my $log = $rule->{log}) {
15891	30					29	for my $tag (@$log) {
15892	30	100				60	if (defined(my $type = $active_log->{$tag})) {
15893	28					30	$key .= ",$type";
15894	28					31	last;
15895							}
15896							}
15897							}
15898	549					1585	$group_rule_tree{$key}->{$this} = $rule;
15899							}
15900
15901							# Find groups >= $min_object_group_size,
15902							# mark rules belonging to one group,
15903							# put groups into an array / hash.
15904	998					1479	for my $href (values %group_rule_tree) {
15905
15906							# $href is {dst/src => rule, ...}
15907	453					536	my $size = keys %$href;
15908	453	100				840	if ($size >= $min_object_group_size) {
15909	46					93	my $glue = {
15910
15911							# Indicator, that no further rules need
15912							# to be processed.
15913							active => 0,
15914
15915							# NAT map for address calculation.
15916							no_nat_set => $hardware->{no_nat_set},
15917
15918							# object-ref => rule, ...
15919							hash => $href
15920							};
15921
15922							# All this rules have identical
15923							# deny, src_range, prt and dst/src
15924							# and shall be replaced by a single new rule
15925							# referencing an object group.
15926	46					63	for my $rule (values %$href) {
15927	142					196	$rule->{group_glue} = $glue;
15928							}
15929							}
15930							}
15931
15932							my $calc_ip_mask_strings = sub {
15933	25			25		27	my ($keys, $no_nat_set) = @_;
15934	94 158	50				253 258	return(map { join('/', @$_) }
15935	94					116	sort { $a->[0] <=> $b->[0] \|\| $a->[1] <=> $b->[1] }
15936	94	50				184	map { address($_, $no_nat_set) }
15937	25					32	map { $ref2obj{$_} \|\| internal_err($_) }
15938							@$keys);
15939	998					2679	};
15940
15941							my $build_group = sub {
15942	24			24		21	my ($ip_mask_strings) = @_;
15943	24					33	my $counter = $router->{vrf_shared_data}->{obj_group_counter}++;
15944
15945	92					185	my $group = new(
15946							'Objectgroup',
15947							name => "g$counter",
15948							elements => $ip_mask_strings,
15949	24					46	hash => { map { $_ => 1 } @$ip_mask_strings },
15950							);
15951
15952							# Print object-group.
15953	24					28	my $numbered = 10;
15954	24					65	print "$keyword $group->{name}\n";
15955	24					29	for my $ip_mask ( @$ip_mask_strings ) {
15956	92					190	my $pair = [ split '/', $ip_mask ];
15957
15958							# Reject network with mask = 0 in group.
15959							# This occurs if optimization didn't work correctly.
15960	92	50				187	$pair->[1] == 0 and
15961							internal_err("Unexpected object with mask 0",
15962							" in object-group of $router->{name}");
15963	92					123	my $adr = cisco_acl_addr($pair, $model);
15964	92	100 50				182	if ($filter_type eq 'NX-OS') {
15965	13					22	print " $numbered $adr\n";
15966	13					23	$numbered += 10;
15967							}
15968							elsif ($filter_type eq 'ACE') {
15969	0					0	print " $adr\n";
15970							}
15971							else {
15972	79					201	print " network-object $adr\n";
15973							}
15974							}
15975	24					37	return $group;
15976	998					2486	};
15977
15978							# Find group with identical elements or define a new one.
15979							my $get_group = sub {
15980	46			46		41	my ($glue) = @_;
15981	46					42	my $hash = $glue->{hash};
15982	46					44	my $no_nat_set = $glue->{no_nat_set};
15983
15984							# Keys are sorted by their internal address to get
15985							# some "first" element.
15986							# This element is useable for hashing, because addresses
15987							# are known to be fix during program execution.
15988	46					134	my @keys = sort keys %$hash;
15989	46					56	my $first = $keys[0];
15990	46					44	my $size = @keys;
15991
15992							# Find group with identical elements.
15993	46					113	HASH:
15994	46					40	for my $group_hash
15995							(@{ $size2first2group_hash->{$size}->{$first} })
15996							{
15997	22					22	my $href = $group_hash->{hash};
15998
15999							# Check elements for equality.
16000	22					20	for my $key (@keys) {
16001	50	50				97	$href->{$key} or next HASH;
16002							}
16003
16004							# Found $group_hash with matching elements.
16005							# Check for existing group in current NAT domain.
16006	22					22	my $nat2group = $group_hash->{nat2group};
16007	22	100				53	if (my $group = $nat2group->{$no_nat_set}) {
16008	21					43	return $group;
16009							}
16010
16011	1					11	my @ip_mask_strings =
16012							$calc_ip_mask_strings->(\@keys, $no_nat_set);
16013
16014							# Check for matching group in other NAT domains.
16015							GROUP:
16016	1					3	for my $group (values %$nat2group) {
16017	1					1	my $href = $group->{hash};
16018
16019							# Check NATed addresses for equality.
16020	1					2	for my $key (@ip_mask_strings) {
16021	2	50				5	$href->{$key} or next GROUP;
16022							}
16023
16024							# Found matching group.
16025	1					1	$nat2group->{$no_nat_set} = $group;
16026	1					3	return $group;
16027							}
16028
16029							# No group found, build new group.
16030	0					0	my $group = $build_group->(\@ip_mask_strings);
16031	0					0	$nat2group->{$no_nat_set} = $group;
16032	0					0	return $group;
16033							}
16034
16035							# No group hash found, build new group hash with new group.
16036	24					44	my @ip_mask_strings =
16037							$calc_ip_mask_strings->(\@keys, $no_nat_set);
16038	24					69	my $group = $build_group->(\@ip_mask_strings);
16039	24					64	my $group_hash = {
16040							hash => $hash,
16041							nat2group => { $no_nat_set => $group },
16042							};
16043	24 24					22 44	push(@{ $size2first2group_hash->{$size}->{$first} },
16044							$group_hash);
16045	24					50	return $group;
16046	998					2646	};
16047
16048							# Build new list of rules using object groups.
16049	998					756	my @new_rules;
16050	998 998					747 1340	for my $rule (@{ $hardware->{$rule_type} }) {
16051
16052							# Remove tag, otherwise call to find_object_groups
16053							# for another router would become confused.
16054	549	100				904	if (my $glue = delete $rule->{group_glue}) {
16055
16056							# debug(print_rule $rule);
16057	142	100				209	if ($glue->{active}) {
16058
16059							# debug(" deleted: $glue->{group}->{name}");
16060	96					135	next;
16061							}
16062	46					72	my $group = $get_group->($glue);
16063
16064							# debug(" generated: $group->{name}");
16065							# # Only needed when debugging.
16066							# $glue->{group} = $group;
16067
16068	46					51	$glue->{active} = 1;
16069	46					83	my ($deny, $srcdst, $src_range, $prt, $log) =
16070	46					41	@{$rule}{'deny', $that, 'src_range', 'prt', 'log'};
16071	46					95	$rule = {
16072							$that => $srcdst,
16073							$this => $group,
16074							prt => $prt
16075							};
16076	46	100				80	$rule->{deny} = $deny if $deny;
16077	46	50				65	$rule->{src_range} = $src_range if $src_range;
16078	46	100				73	$rule->{log} = $log if $log;
16079							}
16080	453					637	push @new_rules, $rule;
16081							}
16082	998					13777	$hardware->{$rule_type} = \@new_rules;
16083							}
16084							}
16085	250					404	return;
16086							}
16087
16088							# Handle iptables.
16089							#
16090							sub debug_bintree {
16091	0			0	0	0	my ($tree, $depth) = @_;
16092	0		0			0	$depth \|\|= '';
16093	0					0	my $ip = print_ip $tree->{ip};
16094	0					0	my $mask = print_ip $tree->{mask};
16095	0	0				0	my $subtree = $tree->{subtree} ? 'subtree' : '';
16096
16097							# debug($depth, " $ip/$mask $subtree");
16098							# debug_bintree($tree->{lo}, "${depth}l") if $tree->{lo};
16099							# debug_bintree($tree->{hi}, "${depth}h") if $tree->{hi};
16100	0					0	return;
16101							}
16102
16103							# Nodes are reverse sorted before being added to bintree.
16104							# Redundant nodes are discarded while inserting.
16105							# A node with value of sub-tree S is discarded,
16106							# if some parent node already has sub-tree S.
16107							sub add_bintree;
16108
16109							sub add_bintree {
16110	28			28	0	29	my ($tree, $node) = @_;
16111	28 28					23 45	my ($tree_ip, $tree_mask) = @{$tree}{qw(ip mask)};
16112	28 28					23 41	my ($node_ip, $node_mask) = @{$node}{qw(ip mask)};
16113	28					22	my $result;
16114
16115							# The case where new node is larger than root node will never
16116							# occur, because nodes are sorted before being added.
16117
16118	28	100 50	67 100			105	if ($tree_mask < $node_mask && match_ip($node_ip, $tree_ip, $tree_mask)) {
16119
16120							# Optimization for this special case:
16121							# Root of tree has attribute {subtree} which is identical to
16122							# attribute {subtree} of current node.
16123							# Node is known to be less than root node.
16124							# Hence node together with its subtree can be discarded
16125							# because it is redundant compared to root node.
16126							# ToDo:
16127							# If this optimization had been done before merge_subtrees,
16128							# it could have merged more subtrees.
16129	6	100	100 67			34	if ( not $tree->{subtree}
16130							or not $node->{subtree}
16131							or $tree->{subtree} ne $node->{subtree})
16132							{
16133	5					8	my $mask = ($tree_mask >> 1) \| 0x80000000;
16134	5	100				8	my $branch = match_ip($node_ip, $tree_ip, $mask) ? 'lo' : 'hi';
16135	5	100				12	if (my $subtree = $tree->{$branch}) {
16136	4					11	$tree->{$branch} = add_bintree $subtree, $node;
16137							}
16138							else {
16139	1					2	$tree->{$branch} = $node;
16140							}
16141							}
16142	6					6	$result = $tree;
16143							}
16144
16145							# Different nodes with identical IP address.
16146							# This shouldn't occur, because different nodes have already
16147							# been converted to an unique object:
16148							# 1. Different interfaces of redundancy protocols like VRRP or HSRP.
16149							# 2. Dynamic NAT of different networks or hosts to a single address
16150							# or range.
16151							elsif ($tree_mask == $node_mask && $tree_ip == $node_ip) {
16152	0		0			0	my $sub1 = $tree->{subtree} \|\| '';
16153	0		0			0	my $sub2 = $node->{subtree} \|\| '';
16154	0	0				0	if ($sub1 ne $sub2) {
16155	0					0	my $ip = print_ip $tree_ip;
16156	0					0	my $mask = print_ip $tree_mask;
16157	0					0	internal_err("Inconsistent rules for iptables for $ip/$mask");
16158							}
16159	0					0	$result = $tree;
16160							}
16161
16162							# Create common root for tree and node.
16163							else {
16164	22					23	while (1) {
16165	221					163	$tree_mask = ($tree_mask & 0x7fffffff) << 1;
16166	221	100				296	last if ($node_ip & $tree_mask) == ($tree_ip & $tree_mask);
16167							}
16168	22					34	$result = new(
16169							'Network',
16170							ip => ($node_ip & $tree_mask),
16171							mask => $tree_mask
16172							);
16173	22 22	50				37 39	@{$result}{qw(lo hi)} =
16174							$node_ip < $tree_ip ? ($node, $tree) : ($tree, $node);
16175							}
16176
16177							# Merge adjacent sub-networks.
16178	28	100				56	MERGE:
16179							{
16180	28					22	$result->{subtree} and last;
16181	26	50				40	my $lo = $result->{lo} or last;
16182	26	50				42	my $hi = $result->{hi} or last;
16183	26					27	my $mask = ($result->{mask} >> 1) \| 0x80000000;
16184	26	100				52	$lo->{mask} == $mask or last;
16185	3	50				10	$hi->{mask} == $mask or last;
16186	3	50	33			13	$lo->{subtree} and $hi->{subtree} or last;
16187	3	100				8	$lo->{subtree} eq $hi->{subtree} or last;
16188
16189	1					1	for my $key (qw(lo hi)) {
16190	2	50				3	$lo->{$key} and last MERGE;
16191	2	50				5	$hi->{$key} and last MERGE;
16192							}
16193
16194							# debug('Merged: ', print_ip $lo->{ip},' ',
16195							# print_ip $hi->{ip},'/',print_ip $hi->{mask});
16196	1					2	$result->{subtree} = $lo->{subtree};
16197	1					2	delete $result->{lo};
16198	1					1	delete $result->{hi};
16199							}
16200	28					69	return $result;
16201							}
16202
16203							# Build a binary tree for src/dst objects.
16204							sub gen_addr_bintree {
16205	108			108	0	104	my ($elements, $tree, $no_nat_set) = @_;
16206
16207							# Sort in reverse order by mask and then by IP.
16208	28	50				78	my @nodes =
16209	132					163	sort { $b->{mask} <=> $a->{mask} \|\| $b->{ip} <=> $a->{ip} }
16210							map {
16211	108 132					106 95	my ($ip, $mask) = @{ address($_, $no_nat_set) };
16212
16213							# The tree's node is a simplified network object with
16214							# missing attribute 'name' and extra 'subtree'.
16215	132					294	new(
16216							'Network',
16217							ip => $ip,
16218							mask => $mask,
16219							subtree => $tree->{$_}
16220							)
16221							} @$elements;
16222	108					98	my $bintree = pop @nodes;
16223	108					200	while (my $next = pop @nodes) {
16224	24					34	$bintree = add_bintree $bintree, $next;
16225							}
16226
16227							# Add attribute {noop} to node which doesn't add any test to
16228							# generated rule.
16229	108	100				178	$bintree->{noop} = 1 if $bintree->{mask} == 0;
16230
16231							# debug_bintree($bintree);
16232	108					143	return $bintree;
16233							}
16234
16235							# Build a tree for src-range/prt objects. Sub-trees for tcp and udp
16236							# will be binary trees. Nodes have attributes {proto}, {range},
16237							# {type}, {code} like protocols (but without {name}).
16238							# Additional attributes for building the tree:
16239							# For tcp and udp:
16240							# {lo}, {hi} for sub-ranges of current node.
16241							# For other protocols:
16242							# {seq} an array of ordered nodes for sub protocols of current node.
16243							# Elements of {lo} and {hi} or elements of {seq} are guaranteed to be
16244							# disjoint.
16245							# Additional attribute {subtree} is set with corresponding subtree of
16246							# protocol object if current node comes from a rule and wasn't inserted
16247							# for optimization.
16248							sub gen_prt_bintree {
16249	101			101	0	98	my ($elements, $tree) = @_;
16250
16251	101					80	my $ip_prt;
16252							my %top_prt;
16253	0					0	my %sub_prt;
16254
16255							# Add all protocols directly below protocol 'ip' into hash %top_prt
16256							# grouped by protocol. Add protocols below top protocols or below
16257							# other protocols of current set of protocols to hash %sub_prt.
16258							PRT:
16259	101					115	for my $prt (@$elements) {
16260	131					134	my $proto = $prt->{proto};
16261	131	100				152	if ($proto eq 'ip') {
16262	12					20	$ip_prt = $prt;
16263							}
16264							else {
16265	119					103	my $up = $prt->{up};
16266
16267							# Check if $prt is sub protocol of any other protocol of
16268							# current set. But handle direct sub protocols of 'ip' as
16269							# top protocols.
16270	119					191	while ($up->{up}) {
16271	61	100				117	if (my $subtree = $tree->{$up}) {
16272
16273							# Found sub protocol of current set.
16274							# Optimization:
16275							# Ignore the sub protocol if both protocols
16276							# have identical subtrees.
16277							# This happens for different objects having identical IP
16278							# from NAT or from redundant interfaces.
16279	6	100				13	if ($tree->{$prt} ne $subtree) {
16280	5 5					4 7	push @{ $sub_prt{$up} }, $prt;
16281							}
16282	6					11	next PRT;
16283							}
16284	55					106	$up = $up->{up};
16285							}
16286
16287							# Not a sub protocol (except possibly of IP).
16288	113	100				225	my $key = $proto =~ /^\d+$/ ? 'proto' : $proto;
16289	113 113					97 269	push @{ $top_prt{$key} }, $prt;
16290							}
16291							}
16292
16293							# Collect subtrees for tcp, udp, proto and icmp.
16294	101					93	my @seq;
16295
16296							# Build subtree of tcp and udp protocols.
16297							#
16298							# We need not to handle 'tcp established' because it is only used
16299							# for stateless routers, but iptables is stateful.
16300							my $gen_lohitrees;
16301	0					0	my $gen_rangetree;
16302							$gen_lohitrees = sub {
16303	143			143		161	my ($prt_aref) = @_;
16304	143	100 100				230	if (not $prt_aref) {
16305	65					102	return (undef, undef);
16306							}
16307							elsif (@$prt_aref == 1) {
16308	69					56	my $prt = $prt_aref->[0];
16309	69					249	my ($lo, $hi) = $gen_lohitrees->($sub_prt{$prt});
16310	69					241	my $node = {
16311							proto => $prt->{proto},
16312							range => $prt->{range},
16313							subtree => $tree->{$prt},
16314							lo => $lo,
16315							hi => $hi
16316							};
16317	69					118	return ($node, undef);
16318							}
16319							else {
16320	9					22	my @ranges =
16321	9					16	sort { $a->{range}->[0] <=> $b->{range}->[0] } @$prt_aref;
16322
16323							# Split array in two halves.
16324	9					17	my $mid = int($#ranges / 2);
16325	9					17	my $left = [ @ranges[ 0 .. $mid ] ];
16326	9					15	my $right = [ @ranges[ $mid + 1 .. $#ranges ] ];
16327	9					28	return ($gen_rangetree->($left), $gen_rangetree->($right));
16328							}
16329	101					388	};
16330							$gen_rangetree = sub {
16331	74			74		65	my ($prt_aref) = @_;
16332	74					110	my ($lo, $hi) = $gen_lohitrees->($prt_aref);
16333	74	100				159	return $lo if not $hi;
16334	8					8	my $proto = $lo->{proto};
16335
16336							# Take low port from lower tree and high port from high tree.
16337	8					19	my $range = [ $lo->{range}->[0], $hi->{range}->[1] ];
16338
16339							# Merge adjacent port ranges.
16340	8	100	60			53	if ( $lo->{range}->[1] + 1 == $hi->{range}->[0]
16341							and $lo->{subtree}
16342							and $hi->{subtree}
16343							and $lo->{subtree} eq $hi->{subtree})
16344							{
16345	12					17	my @hilo =
16346	3					6	grep { defined $_ } $lo->{lo}, $lo->{hi}, $hi->{lo}, $hi->{hi};
16347	3	100				8	if (@hilo <= 2) {
16348
16349							# debug("Merged: $lo->{range}->[0]-$lo->{range}->[1]",
16350							# " $hi->{range}->[0]-$hi->{range}->[1]");
16351	2					6	my $node = {
16352							proto => $proto,
16353							range => $range,
16354							subtree => $lo->{subtree}
16355							};
16356	2	100				4	$node->{lo} = shift @hilo if @hilo;
16357	2	100				4	$node->{hi} = shift @hilo if @hilo;
16358	2					8	return $node;
16359							}
16360							}
16361							return (
16362							{
16363	6					18	proto => $proto,
16364							range => $range,
16365							lo => $lo,
16366							hi => $hi
16367							}
16368							);
16369	101					284	};
16370	101					114	for my $what (qw(tcp udp)) {
16371	202	100				392	next if not $top_prt{$what};
16372	56					87	push @seq, $gen_rangetree->($top_prt{$what});
16373							}
16374
16375							# Add single nodes for numeric protocols.
16376	101	100				173	if (my $aref = $top_prt{proto}) {
16377	8 0					10 0	for my $prt (sort { $a->{proto} <=> $b->{proto} } @$aref) {
16378	8					21	my $node = { proto => $prt->{proto}, subtree => $tree->{$prt} };
16379	8					12	push @seq, $node;
16380							}
16381							}
16382
16383							# Build subtree of icmp protocols.
16384	101	100				156	if (my $icmp_aref = $top_prt{icmp}) {
16385	37					28	my %type2prt;
16386							my $icmp_any;
16387
16388							# If one protocol is 'icmp any' it is the only top protocol,
16389							# all other icmp protocols are sub protocols.
16390	37	100				69	if (not defined $icmp_aref->[0]->{type}) {
16391	20					17	$icmp_any = $icmp_aref->[0];
16392	20					28	$icmp_aref = $sub_prt{$icmp_any};
16393							}
16394
16395							# Process icmp protocols having defined type and possibly defined code.
16396							# Group protocols by type.
16397	37					46	for my $prt (@$icmp_aref) {
16398	21					23	my $type = $prt->{type};
16399	21 21					17 47	push @{ $type2prt{$type} }, $prt;
16400							}
16401
16402							# Parameter is array of icmp protocols all having
16403							# the same type and different but defined code.
16404							# Return reference to array of nodes sorted by code.
16405							my $gen_icmp_type_code_sorted = sub {
16406	0			0		0	my ($aref) = @_;
16407							[
16408	0					0	map {
16409	0					0	{
16410							proto => 'icmp',
16411							type => $_->{proto},
16412							code => $_->{code},
16413							subtree => $tree->{$_}
16414							}
16415							}
16416	0					0	sort { $a->{code} <=> $b->{code} } @$aref
16417							];
16418	37					105	};
16419
16420							# For collecting subtrees of icmp subtree.
16421	37					29	my @seq2;
16422
16423							# Process grouped icmp protocols having the same type.
16424	37 4					71 10	for my $type (sort { $a <=> $b } keys %type2prt) {
16425	21					21	my $aref2 = $type2prt{$type};
16426	21					17	my $node2;
16427
16428							# If there is more than one protocol,
16429							# all have same type and defined code.
16430	21	50				31	if (@$aref2 > 1) {
16431	0					0	my $seq3 = $gen_icmp_type_code_sorted->($aref2);
16432
16433							# Add a node 'icmp type any' as root.
16434	0					0	$node2 = {
16435							proto => 'icmp',
16436							type => $type,
16437							seq => $seq3,
16438							};
16439							}
16440
16441							# One protocol 'icmp type any'.
16442							else {
16443	21					20	my $prt = $aref2->[0];
16444	21					61	$node2 = {
16445							proto => 'icmp',
16446							type => $type,
16447							subtree => $tree->{$prt}
16448							};
16449	21	50				47	if (my $aref3 = $sub_prt{$prt}) {
16450	0					0	$node2->{seq} = $gen_icmp_type_code_sorted->($aref3);
16451							}
16452							}
16453	21					38	push @seq2, $node2;
16454							}
16455
16456							# Add root node for icmp subtree.
16457	37					35	my $node;
16458	37	100 100				58	if ($icmp_any) {
16459	20					57	$node = {
16460							proto => 'icmp',
16461							seq => \@seq2,
16462							subtree => $tree->{$icmp_any}
16463							};
16464							}
16465							elsif (@seq2 > 1) {
16466	4					8	$node = { proto => 'icmp', seq => \@seq2 };
16467							}
16468							else {
16469	13					12	$node = $seq2[0];
16470							}
16471	37					140	push @seq, $node;
16472							}
16473
16474							# Add root node for whole tree.
16475	101					69	my $bintree;
16476	101	100 100				173	if ($ip_prt) {
16477	12					33	$bintree = {
16478							proto => 'ip',
16479							seq => \@seq,
16480							subtree => $tree->{$ip_prt}
16481							};
16482							}
16483							elsif (@seq > 1) {
16484	8					11	$bintree = { proto => 'ip', seq => \@seq };
16485							}
16486							else {
16487	81					74	$bintree = $seq[0];
16488							}
16489
16490							# Add attribute {noop} to node which doesn't need any test in
16491							# generated chain.
16492	101	100				185	$bintree->{noop} = 1 if $bintree->{proto} eq 'ip';
16493	101					200	return $bintree;
16494							}
16495
16496							my %ref_type = (
16497							src => \%ref2obj,
16498							dst => \%ref2obj,
16499							src_prt => \%ref2prt,
16500							prt => \%ref2prt,
16501							);
16502
16503							sub find_chains {
16504	60			60	0	58	my ($router, $hardware) = @_;
16505
16506							# For generating names of chains.
16507							# Initialize if called first time.
16508	60		100			162	$router->{vrf_shared_data}->{chain_counter} \|\|= 1;
16509
16510	60					56	my $no_nat_set = $hardware->{no_nat_set};
16511	60					47	my $io_rules_hash = $hardware->{io_rules};
16512	60 22					129 46	my @rule_arefs = map { $io_rules_hash->{$_} } sort keys %$io_rules_hash;
16513	60					59	my $intf_rules = $hardware->{intf_rules};
16514	60	100				97	push @rule_arefs, $intf_rules if $intf_rules;
16515
16516	60					67	for my $rules (@rule_arefs) {
16517
16518							# Change rules to allow optimization of objects having
16519							# identical IP adress.
16520							# This is crucial for correct operation of sub add_bintree.
16521							# Otherwise internal_err("Inconsistent rules for iptables")
16522							# would be triggered.
16523	43					44	for my $rule (@$rules) {
16524
16525							# Restore {action} attribute in $rule, so we can handle
16526							# all properties of a rule in unified manner.
16527							# {src_range} attribute is unset for value $prt_ip.
16528							# This needs to be set here, but only for iptables.
16529							# Hence use new attribute {src_prt}.
16530							# $rule needs not to be copied:
16531							# - other device types will ignore this attributes,
16532							# - other linux devices will reuse them.
16533	104	100				147	if (!$rule->{action}) {
16534	91	50				151	$rule->{action} = $rule->{deny} ? 'deny' : 'permit';
16535	91					84	my $src_prt = $rule->{src_range};
16536	91	50				124	if (not $src_prt) {
16537	91					100	my $proto = $rule->{prt}->{proto};
16538
16539							# Specify protocols tcp, udp, icmp in
16540							# {src_prt}, to get more efficient chains.
16541	91	100 100 100				158	$src_prt = $proto eq 'tcp' ? $prt_tcp->{dst_range}
16542							: $proto eq 'udp' ? $prt_udp->{dst_range}
16543							: $proto eq 'icmp' ? $prt_icmp
16544							: $prt_ip;
16545							}
16546	91					116	$rule->{src_prt} = $src_prt;
16547							}
16548
16549	104					79	my $copied;
16550	104					96	for my $what (qw(src dst)) {
16551	208					206	my $orig = my $obj = $rule->{$what};
16552
16553							# Loopback interface is converted to loopback network,
16554							# because other networks may have this loopback network
16555							# as value in {is_identical}.
16556	208	100	100			358	if ($obj->{loopback} && (my $network = $obj->{network})) {
16557	8	50	50			38	if (!($intf_rules && $rules eq $intf_rules &&
16558							$what eq 'dst'))
16559							{
16560	2					3	$obj = $network;
16561							}
16562							}
16563
16564							# Identical networks from dynamic NAT and
16565							# from identical aggregates.
16566	208	100 100				391	if (my $identical = $obj->{is_identical}) {
16567	12	100				26	if (my $other = $identical->{$no_nat_set}) {
16568	6					6	$obj = $other;
16569							}
16570							}
16571
16572							# Identical redundancy interfaces.
16573							elsif (my $aref = $obj->{redundancy_interfaces}) {
16574	4	50	25			25	if (!($intf_rules && $rules eq $intf_rules &&
16575							$what eq 'dst'))
16576							{
16577	0					0	$obj = $aref->[0];
16578							}
16579							}
16580
16581	208	100				539	$obj eq $orig and next;
16582
16583							# Don't change rules of devices in other NAT domain
16584							# where we may have other {is_identical} relation.
16585	8	50				36	$rule = { %$rule } if !$copied++;
16586	8					22	$rule->{$what} = $obj;
16587							}
16588							}
16589
16590	43					38	my %cache;
16591
16592							my $print_tree;
16593							$print_tree = sub {
16594	0			0		0	my ($tree, $order, $depth) = @_;
16595	0					0	my $key = $order->[$depth];
16596	0					0	my $ref2x = $ref_type{$key};
16597	0 0					0 0	my @elements = map { $ref2x->{$_} } keys %$tree;
16598	0					0	for my $elem (@elements) {
16599
16600							# debug(' ' x $depth, "$elem->{name}");
16601	0	0				0	if ($depth < $#$order) {
16602	0					0	$print_tree->($tree->{$elem}, $order, $depth + 1);
16603							}
16604							}
16605	43					152	};
16606
16607							my $insert_bintree = sub {
16608	209			209		190	my ($tree, $order, $depth) = @_;
16609	209					210	my $key = $order->[$depth];
16610	209					196	my $ref2x = $ref_type{$key};
16611	209 263					1265 413	my @elements = map { $ref2x->{$_} } keys %$tree;
16612
16613							# Put prt/src/dst objects at the root of some subtree into a
16614							# (binary) tree. This is used later to convert subsequent tests
16615							# for ip/mask or port ranges into more efficient nested chains.
16616	209					188	my $bintree;
16617	209	100				378	if ($ref2x eq \%ref2obj) {
16618	108					157	$bintree = gen_addr_bintree(\@elements, $tree, $no_nat_set);
16619							}
16620							else { # $ref2x eq \%ref2prt
16621	101					139	$bintree = gen_prt_bintree(\@elements, $tree);
16622							}
16623	209					715	return $bintree;
16624	43					118	};
16625
16626							# Used by $merge_subtrees1 to find identical subtrees.
16627							# Use hash for efficient lookup.
16628	43					35	my %depth2size2subtrees;
16629							my %subtree2bintree;
16630
16631							# Find and merge identical subtrees.
16632							my $merge_subtrees1 = sub {
16633	147			147		133	my ($tree, $order, $depth) = @_;
16634
16635							SUBTREE:
16636	147					187	for my $subtree (values %$tree) {
16637	174					268	my @keys = keys %$subtree;
16638	174					177	my $size = @keys;
16639
16640							# Find subtree with identical keys and values;
16641	174					377	FIND:
16642	174					135	for my $subtree2 (@{ $depth2size2subtrees{$depth}->{$size} }) {
16643	36					37	for my $key (@keys) {
16644	43	100	100			124	if (not $subtree2->{$key}
16645							or $subtree2->{$key} ne $subtree->{$key})
16646							{
16647	28					50	next FIND;
16648							}
16649							}
16650
16651							# Substitute current subtree with found subtree.
16652	8					13	$subtree = $subtree2bintree{$subtree2};
16653	8					25	next SUBTREE;
16654
16655							}
16656
16657							# Found a new subtree.
16658	166 166					145 218	push @{ $depth2size2subtrees{$depth}->{$size} }, $subtree;
16659	166					248	$subtree = $subtree2bintree{$subtree} =
16660							$insert_bintree->($subtree, $order, $depth + 1);
16661							}
16662	43					125	};
16663
16664							my $merge_subtrees = sub {
16665	43			43		44	my ($tree, $order) = @_;
16666
16667							# Process leaf nodes first.
16668	43					70	for my $href (values %$tree) {
16669	50					68	for my $href (values %$href) {
16670	54					74	$merge_subtrees1->($href, $order, 2);
16671							}
16672							}
16673
16674							# Process nodes next to leaf nodes.
16675	43					64	for my $href (values %$tree) {
16676	50					62	$merge_subtrees1->($href, $order, 1);
16677							}
16678
16679							# Process nodes next to root.
16680	43					65	$merge_subtrees1->($tree, $order, 0);
16681	43					67	return $insert_bintree->($tree, $order, 0);
16682	43					111	};
16683
16684							# Add new chain to current router.
16685							my $new_chain = sub {
16686	36			36		34	my ($rules) = @_;
16687	36					51	my $counter = $router->{vrf_shared_data}->{chain_counter}++;
16688	36					85	my $chain = new(
16689							'Chain',
16690							name => "c$counter",
16691							rules => $rules,
16692							);
16693	36 36					36 51	push @{ $router->{chains} }, $chain;
16694	36					42	$chain;
16695	43					97	};
16696
16697	43					35	my $gen_chain;
16698							$gen_chain = sub {
16699	250			250		240	my ($tree, $order, $depth) = @_;
16700	250					230	my $key = $order->[$depth];
16701	250					176	my @rules;
16702
16703							# We need the original value later.
16704	250					182	my $bintree = $tree;
16705	250					184	while (1) {
16706	297					424	my ($hi, $lo, $seq, $subtree) =
16707	297					226	@{$bintree}{qw(hi lo seq subtree)};
16708	297	100	100			528	$seq = undef if $seq and not @$seq;
16709	297	100				383	if (not $seq) {
16710	281	100				363	push @$seq, $hi if $hi;
16711	281	100				370	push @$seq, $lo if $lo;
16712							}
16713	297	100				386	if ($subtree) {
16714
16715							# if($order->[$depth+1]&&
16716							# $order->[$depth+1] =~ /^(src\|dst)$/) {
16717							# debug($order->[$depth+1]);
16718							# debug_bintree($subtree);
16719							# }
16720	258					273	my $rules = $cache{$subtree};
16721	258	100				328	if (not $rules) {
16722	209	100				776	$rules =
16723							$depth + 1 >= @$order
16724							? [ { action => $subtree } ]
16725							: $gen_chain->($subtree, $order, $depth + 1);
16726	209	100	100			389	if (@$rules > 1 and not $bintree->{noop}) {
16727	9					13	my $chain = $new_chain->($rules);
16728	9					18	$rules = [ { action => $chain, goto => 1 } ];
16729							}
16730	209					350	$cache{$subtree} = $rules;
16731							}
16732
16733	258					173	my @add_keys;
16734
16735							# Don't use "goto", if some tests for sub-nodes of
16736							# $subtree are following.
16737	258	100				349	push @add_keys, (goto => 0) if $seq;
16738	258	100				458	push @add_keys, ($key => $bintree) if not $bintree->{noop};
16739	258	100				305	if (@add_keys) {
16740
16741							# Create a copy of each rule because we must not change
16742							# the original cached rules.
16743	239					819	push @rules, map {
16744	239					238	{ (%$_, @add_keys) }
16745							} @$rules;
16746							}
16747							else {
16748	19					27	push @rules, @$rules;
16749							}
16750							}
16751	297	100				469	last if not $seq;
16752
16753							# Take this value in next iteration.
16754	47					39	$bintree = pop @$seq;
16755
16756							# Process remaining elements.
16757	47					58	for my $node (@$seq) {
16758	41					119	my $rules = $gen_chain->($node, $order, $depth);
16759	41					102	push @rules, @$rules;
16760							}
16761							}
16762	250	100	100			512	if (@rules > 1 and not $tree->{noop}) {
16763
16764							# Generate new chain. All elements of @seq are
16765							# known to be disjoint. If one element has matched
16766							# and branched to a chain, then the other elements
16767							# need not be tested again. This is implemented by
16768							# calling the chain using '-g' instead of the usual '-j'.
16769	27					39	my $chain = $new_chain->(\@rules);
16770	27					73	return [ { action => $chain, goto => 1, $key => $tree } ];
16771							}
16772							else {
16773	223					314	return \@rules;
16774							}
16775	43					168	};
16776
16777							# Build rule trees. Generate and process separate tree for
16778							# adjacent rules with same action.
16779	43					37	my @rule_trees;
16780							my %tree2order;
16781	43	50	33			149	if ($rules and @$rules) {
16782	43					55	my $prev_action = $rules->[0]->{action};
16783
16784							# Special rule as marker, that end of rules has been reached.
16785	43					76	push @$rules, { action => 0 };
16786	43					42	my $start = my $i = 0;
16787	43					42	my $last = $#$rules;
16788	43					36	my %count;
16789	43					35	while (1) {
16790	147					115	my $rule = $rules->[$i];
16791	147					133	my $action = $rule->{action};
16792	147	100				187	if ($action eq $prev_action) {
16793
16794							# Count, which key has the largest number of
16795							# different values.
16796	104					101	for my $what (qw(src dst src_prt prt)) {
16797	416					736	$count{$what}{ $rule->{$what} } = 1;
16798							}
16799	104					105	$i++;
16800							}
16801							else {
16802
16803							# Use key with smaller number of different values
16804							# first in rule tree. This gives smaller tree and
16805							# fewer tests in chains.
16806	179					211	my @test_order =
16807	43 179 179					76 140 259	sort { keys %{ $count{$a} } <=> keys %{ $count{$b} } }
16808							qw(src_prt dst prt src);
16809	43					35	my $rule_tree;
16810	43					46	my $end = $i - 1;
16811	43					84	for (my $j = $start ; $j <= $end ; $j++) {
16812	104					87	my $rule = $rules->[$j];
16813	104					176	my ($action, $t1, $t2, $t3, $t4) =
16814	104					85	@{$rule}{ 'action', @test_order };
16815	104					427	$rule_tree->{$t1}->{$t2}->{$t3}->{$t4} = $action;
16816							}
16817	43					44	push @rule_trees, $rule_tree;
16818
16819							# debug(join ', ', @test_order);
16820	43					68	$tree2order{$rule_tree} = \@test_order;
16821	43	50				98	last if not $action;
16822	0					0	$start = $i;
16823	0					0	$prev_action = $action;
16824							}
16825							}
16826	43					194	@$rules = ();
16827							}
16828
16829	43					81	for (my $i = 0 ; $i < @rule_trees ; $i++) {
16830	43					41	my $tree = $rule_trees[$i];
16831	43					52	my $order = $tree2order{$tree};
16832
16833							# $print_tree->($tree, $order, 0);
16834	43					124	$tree = $merge_subtrees->($tree, $order);
16835	43					67	my $result = $gen_chain->($tree, $order, 0);
16836
16837							# Goto must not be used in last rule of rule tree which is
16838							# not the last tree.
16839	43	50				82	if ($i != $#rule_trees) {
16840	0					0	my $rule = $result->[-1];
16841	0					0	delete $rule->{goto};
16842							}
16843
16844							# Postprocess rules: Add missing attributes prt, src, dst
16845							# with no-op values.
16846	43					56	for my $rule (@$result) {
16847	53		67			114	$rule->{src} \|\|= $network_00;
16848	53		67			95	$rule->{dst} \|\|= $network_00;
16849	53					47	my $prt = $rule->{prt};
16850	53					50	my $src_prt = $rule->{src_prt};
16851	53	100 100	100			182	if (not $prt and not $src_prt) {
16852	4					8	$rule->{prt} = $prt_ip;
16853							}
16854							elsif (not $prt) {
16855	2	50 50 100				8	$rule->{prt} =
16856							$src_prt->{proto} eq 'tcp' ? $prt_tcp->{dst_range}
16857							: $src_prt->{proto} eq 'udp' ? $prt_udp->{dst_range}
16858							: $src_prt->{proto} eq 'icmp' ? $prt_icmp
16859							: $prt_ip;
16860
16861							# Restore {src_range} from {src_prt}, because
16862							# {src_range} is only used in find_chains.
16863	2					6	$rule->{src_range} = delete $rule->{src_prt}
16864							}
16865							}
16866	43					670	push @$rules, @$result;
16867							}
16868							}
16869	60					101	return;
16870							}
16871
16872							# Print chains of iptables.
16873							# Objects have already been normalized to ip/mask pairs.
16874							# NAT has already been applied.
16875							sub print_chains {
16876	34			34	0	34	my ($router) = @_;
16877
16878							# Declare chain names.
16879	34 34					32 53	for my $chain (@{ $router->{chains} }) {
16880	36					35	my $name = $chain->{name};
16881	36					58	print ":$name -\n";
16882							}
16883
16884							# Define chains.
16885	34 34					33 45	for my $chain (@{ $router->{chains} }) {
16886	36					36	my $name = $chain->{name};
16887	36					40	my $prefix = "-A $name";
16888
16889							# my $steps = my $accept = my $deny = 0;
16890	36 36					30 43	for my $rule (@{ $chain->{rules} }) {
16891	75					76	my $action = $rule->{action};
16892	75	50 100				96	my $action_code =
16893							is_chain($action) ? $action->{name}
16894							: $action eq 'permit' ? 'ACCEPT'
16895							: 'droplog';
16896
16897							# Calculate maximal number of matches if
16898							# - some rules matches (accept) or
16899							# - all rules don't match (deny).
16900							# $steps += 1;
16901							# if ($action eq 'permit') {
16902							# $accept = max($accept, $steps);
16903							# }
16904							# elsif ($action eq 'deny') {
16905							# $deny = max($deny, $steps);
16906							# }
16907							# elsif ($rule->{goto}) {
16908							# $accept = max($accept, $steps + $action->{a});
16909							# }
16910							# else {
16911							# $accept = max($accept, $steps + $action->{a});
16912							# $steps += $action->{d};
16913							# }
16914
16915	75	100				110	my $jump = $rule->{goto} ? '-g' : '-j';
16916	75					90	my $result = "$jump $action_code";
16917	75	100				121	if (my $src = $rule->{src}) {
16918	42 42					37 69	my $ip_mask = [ @{$src}{qw(ip mask)} ];
16919	42	50				75	if ($ip_mask->[1] != 0) {
16920	42					62	$result .= ' -s ' . prefix_code($ip_mask);
16921							}
16922							}
16923	75	100				129	if (my $dst = $rule->{dst}) {
16924	15 15					12 26	my $ip_mask = [ @{$dst}{qw(ip mask)} ];
16925	15	50				29	if ($ip_mask->[1] != 0) {
16926	15					18	$result .= ' -d ' . prefix_code($ip_mask);
16927							}
16928							}
16929							ADD_PROTO:
16930							{
16931	75 75					55 65	my $src_prt = $rule->{src_prt};
16932	75					63	my $prt = $rule->{prt};
16933	75	100	67			178	last ADD_PROTO if not $src_prt and not $prt;
16934	40	50	67			124	last ADD_PROTO if $prt and $prt->{proto} eq 'ip';
16935	40	100				57	if (not $prt) {
16936	2	50				4	last ADD_PROTO if $src_prt->{proto} eq 'ip';
16937	2	50 50 100				7	$prt =
16938							$src_prt->{proto} eq 'tcp' ? $prt_tcp->{dst_range}
16939							: $src_prt->{proto} eq 'udp' ? $prt_udp->{dst_range}
16940							: $src_prt->{proto} eq 'icmp' ? $prt_icmp
16941							: $prt_ip;
16942							}
16943
16944							# debug("c ",print_rule $rule) if not $src_range or not $prt;
16945	40					52	$result .= ' ' . iptables_prt_code($src_prt, $prt);
16946							}
16947	75					224	print "$prefix $result\n";
16948							}
16949
16950							# $deny = max($deny, $steps);
16951							# $chain->{a} = $accept;
16952							# $chain->{d} = $deny;
16953							# print "# Max tests: Accept: $accept, Deny: $deny\n";
16954							}
16955
16956							# Empty line as delimiter.
16957	34					39	print "\n";
16958	34					31	return;
16959							}
16960
16961							# Find adjacent port ranges.
16962							sub join_ranges {
16963	514			514	0	443	my ($router, $hardware) = @_;
16964	514					374	my $changed;
16965	514					467	my $active_log = $router->{log};
16966	514					526	for my $rules ('intf_rules', 'rules', 'out_rules') {
16967	1542					1366	my %hash = ();
16968	1542					1985	RULE:
16969	1542					1094	for my $rule (@{ $hardware->{$rules} }) {
16970	592					826	my ($deny, $src, $dst, $src_range, $prt) =
16971	592					484	@{$rule}{qw(deny src dst src_range prt)};
16972
16973							# Only ranges which have a neighbor may be successfully optimized.
16974							# Currently only dst_ranges are handled.
16975	592	100				1152	$prt->{has_neighbor} or next;
16976
16977	90		50			199	$deny \|\|= '';
16978	90		50			188	$src_range \|\|= '';
16979	90					287	$hash{$deny}->{$src}->{$dst}->{$src_range}->{$prt} = $rule;
16980							}
16981
16982							# %hash is {deny => href, ...}
16983	1542					2196	for my $href (values %hash) {
16984
16985							# $href is {src => href, ...}
16986	24					39	for my $href (values %$href) {
16987
16988							# $href is {dst => href, ...}
16989	36					45	for my $href (values %$href) {
16990
16991							# $href is {src_range => href, ...}
16992	70					88	for my $src_range_ref (keys %$href) {
16993	70					62	my $href = $href->{$src_range_ref};
16994
16995							# Nothing to do if only a single rule.
16996	70	100				191	next if values %$href == 1;
16997
16998							# Values of %$href are rules with identical
16999							# deny/src/dst/src_range and a TCP or UDP protocol.
17000							#
17001							# Collect rules with identical log type and
17002							# identical protocol.
17003	12					11	my %key2rules;
17004	12					17	for my $rule (values %$href) {
17005	32					35	my $key = $rule->{prt}->{proto};
17006	32	100				51	if (my $log = $rule->{log}) {
17007	14					13	for my $tag (@$log) {
17008	14	100				30	if (defined(my $type = $active_log->{$tag}))
17009							{
17010	10					11	$key .= ",$type";
17011	10					10	last;
17012							}
17013							}
17014							}
17015	32 32					26 59	push @{ $key2rules{$key} }, $rule;
17016							}
17017
17018	12					21	for my $rules (values %key2rules) {
17019
17020							# When sorting these rules by low port number,
17021							# rules with adjacent protocols will placed
17022							# side by side. There can't be overlaps,
17023							# because they have been split in function
17024							# 'order_ranges'. There can't be sub-ranges,
17025							# because they have been deleted as redundant
17026							# above.
17027	14					35	my @sorted = sort {
17028	19					29	$a->{prt}->{range}->[0]
17029							<=>
17030							$b->{prt}->{range}->[0]
17031							} @$rules;
17032	19	100				50	@sorted >= 2 or next;
17033	11					11	my $i = 0;
17034	11					11	my $rule_a = $sorted[$i];
17035	11 11					10 19	my ($a1, $a2) = @{ $rule_a->{prt}->{range} };
17036	11					22	while (++$i < @sorted) {
17037	13					17	my $rule_b = $sorted[$i];
17038	13 13					13 19	my ($b1, $b2) = @{ $rule_b->{prt}->{range} };
17039	13	100				23	if ($a2 + 1 == $b1) {
17040
17041							# Found adjacent port ranges.
17042	8	100				24	if (my $range = delete $rule_a->{range}) {
17043
17044							# Extend range of previous two or
17045							# more elements.
17046	2					1	$range->[1] = $b2;
17047	2					2	$rule_b->{range} = $range;
17048							}
17049							else {
17050
17051							# Combine ranges of $rule_a and $rule_b.
17052	6					13	$rule_b->{range} = [ $a1, $b2 ];
17053							}
17054
17055							# Mark previous rule as deleted.
17056							# Don't use attribute 'deleted', this
17057							# may still be set by global
17058							# optimization pass.
17059	8					14	$rule_a->{local_del} = 1;
17060	8					8	$changed = 1;
17061							}
17062	13					10	$rule_a = $rule_b;
17063	13					55	($a1, $a2) = ($b1, $b2);
17064							}
17065							}
17066							}
17067							}
17068							}
17069							}
17070	1542	100				2793	if ($changed) {
17071	12					13	my @rules;
17072	12 12					9 24	for my $rule (@{ $hardware->{$rules} }) {
17073
17074							# Check and remove attribute 'local_del'.
17075	26	100				41	next if delete $rule->{local_del};
17076
17077							# Process rules with joined port ranges.
17078							# Remove auxiliary attribute {range} from rules.
17079	18	100				30	if (my $range = delete $rule->{range}) {
17080	6					7	my $prt = $rule->{prt};
17081	6					8	my $proto = $prt->{proto};
17082	6					13	my $key = join(':', @$range);
17083
17084							# Try to find existing prt with matching range.
17085							# This is needed for find_object_groups to work.
17086	6					11	my $new_prt = $prt_hash{$proto}->{$key};
17087	6	100				10	unless ($new_prt) {
17088	5					18	$new_prt = {
17089							name => "joined:$prt->{name}",
17090							proto => $proto,
17091							range => $range
17092							};
17093	5					9	$prt_hash{$proto}->{$key} = $new_prt;
17094							}
17095	6					22	my $new_rule = { %$rule, prt => $new_prt };
17096	6					14	push @rules, $new_rule;
17097							}
17098							else {
17099	12					17	push @rules, $rule;
17100							}
17101							}
17102	12					39	$hardware->{$rules} = \@rules;
17103							}
17104							}
17105	514					1155	return;
17106							}
17107
17108							# Reuse network objects at different interfaces,
17109							# so we get reused object-groups.
17110							my %filter_networks;
17111
17112							sub get_filter_network {
17113	38			38	0	38	my ($ip, $mask) = @_;
17114	38					57	my $key = "$ip/$mask";
17115	38					39	my $net = $filter_networks{$key};
17116	38	100				54	if (!$net) {
17117	14					20	$net = new('Network', ip => $ip, mask => $mask);
17118	14					16	$filter_networks{$key} = $net;
17119	14					24	$ref2obj{$net} = $net;
17120							}
17121	38					76	return $net;
17122							}
17123
17124							# Remove rules on device which filters only locally.
17125							sub remove_non_local_rules {
17126	514			514	0	466	my ($router, $hardware) = @_;
17127	514	100				1046	$router->{managed} =~ /^local/ or return;
17128
17129	35					37	my $no_nat_set = $hardware->{no_nat_set};
17130	35					29	my $filter_only = $router->{filter_only};
17131	35					36	for my $rules ('rules', 'out_rules') {
17132	70					48	my $changed;
17133	70 70					52 105	for my $rule (@{ $hardware->{$rules} }) {
17134
17135							# Don't remove deny rule
17136	27	50				41	next if $rule->{deny};
17137	27					25	my $both_match = 0;
17138	27					22	for my $what (qw(src dst)) {
17139	54					56	my $obj = $rule->{$what};
17140	54 54					39 64	my ($ip, $mask) = @{ address($obj, $no_nat_set) };
17141	54					71	for my $pair (@$filter_only) {
17142	56					55	my ($i, $m) = @$pair;
17143
17144							# src/dst matches filter_only or
17145							# filter_only matches src/dst.
17146	56	100	100			119	if ($mask > $m && match_ip($ip, $i, $m) \|\|
17147							match_ip($i, $ip, $mask))
17148							{
17149	50					38	$both_match++;
17150	50					79	last;
17151							}
17152							}
17153							}
17154
17155							# Either src or dst or both are extern.
17156							# The rule will not be filtered at this device.
17157	27	100				53	if ($both_match < 2) {
17158	4					3	$rule = undef;
17159	4					6	$changed = 1;
17160							}
17161							}
17162							$changed and
17163	70 6 4	100				125 10 6	$hardware->{$rules} = [ grep { $_ } @{ $hardware->{$rules} } ];
17164							}
17165	35					44	return;
17166							}
17167
17168							# Add deny and permit rules at device which filters only locally.
17169							sub add_local_deny_rules {
17170	514			514	0	491	my ($router, $hardware) = @_;
17171	514	100				1102	$router->{managed} =~ /^local/ or return;
17172	35	100				57	$hardware->{crosslink} and return;
17173
17174	32					28	my $filter_only = $router->{filter_only};
17175	32 38					34 53	my @dst_networks = map { get_filter_network(@$_) } @$filter_only;
17176
17177	32					38	for my $attr (qw(rules out_rules)) {
17178
17179	64	100	100			167	next if $attr eq 'rules' && $hardware->{no_in_acl};
17180	63	100	100			163	next if $attr eq 'out_rules' && ! $hardware->{need_out_acl};
17181
17182							# If attached zone has only one connection to this firewall
17183							# than we don't need to check the source address. It has
17184							# already been checked, that all networks of this zone match
17185							# {filter_only}.
17186							my $check = sub {
17187	32	100		32		53	$attr eq 'out_rules' and return;
17188	31 31					20 44	for my $interface (@{ $hardware->{interfaces} }) {
17189	33					32	my $zone = $interface->{zone};
17190	33	50				47	$zone->{zone_cluster} and return;
17191
17192							# Ignore real interface of virtual interface.
17193	69 33					118 37	my @interfaces = grep({ ! $_->{main_interface} }
17194	33					27	@{ $zone->{interfaces} });
17195
17196	33	100				66	if (@interfaces > 1) {
17197
17198
17199							# Multilpe interfaces belonging to one redundancy
17200							# group can't be used to cross the zone.
17201	47					40	my @redundant =
17202	47					56	grep { $_ }
17203	19					19	map { $_->{redundancy_interfaces} } @interfaces;
17204	19	100	67			64	@redundant == @interfaces and equal(@redundant)
17205							or return;
17206							}
17207							}
17208	16					34	return 1;
17209	32					95	};
17210	32	100				45	my @src_networks = $check->() ? ($network_00) : @dst_networks;
17211
17212	32					25	my @filter_rules;
17213	32					32	for my $src (@src_networks) {
17214	35					30	for my $dst (@dst_networks) {
17215	44					142	push(@filter_rules,
17216							{
17217							deny => 1,
17218							src => $src,
17219							dst => $dst,
17220							prt => $prt_ip
17221							});
17222							}
17223							}
17224	32					37	my $rules = $hardware->{$attr};
17225	32					156	push @$rules, @filter_rules, $permit_any_rule;
17226							}
17227	32					41	return;
17228							}
17229
17230							sub prepare_local_optimization {
17231
17232							# Prepare rules for local_optimization.
17233							# Aggregates with mask 0 are converted to network_00, to be able
17234							# to compare with internally generated rules which use network_00.
17235	155 155			155	0	150 240	for my $rule (@{ $expanded_rules{supernet} }) {
17236	105	100	100			214	next if $rule->{deleted} and not $rule->{managed_intf};
17237	104 104					89 150	my ($src, $dst) = @{$rule}{qw(src dst)};
17238	104	100	100			133	$rule->{src} = $network_00 if is_network($src) && $src->{mask} == 0;
17239	104	100	100			136	$rule->{dst} = $network_00 if is_network($dst) && $dst->{mask} == 0;
17240							}
17241	155					145	return;
17242							}
17243
17244							#use Time::HiRes qw ( time );
17245							sub local_optimization {
17246	208	100		208	0	260	return if fast_mode();
17247	155					233	progress('Optimizing locally');
17248
17249							# Needed in find_chains.
17250	155					286	$ref2obj{$network_00} = $network_00;
17251
17252	155					127	my %seen;
17253
17254							# For debugging only
17255							# my %time;
17256							# my %r2rules;
17257							# my %r2id;
17258							# my %r2del;
17259							# my %r2sec;
17260	155					195	for my $domain (@natdomains) {
17261	189					201	my $no_nat_set = $domain->{no_nat_set};
17262
17263							# Subnet relation may be different for each NAT domain,
17264							# therefore it is set up again for each NAT domain.
17265	189					195	for my $network (@networks) {
17266	841	100	67			2434	next if !$network->{mask} \|\| $network->{mask} == 0;
17267	739					932	my $up = $network->{is_in}->{$no_nat_set};
17268	739	100	100			1588	if (!$up \|\| $up->{mask} == 0) {
17269	629					499	$up = $network_00;
17270							}
17271	739					938	$network->{up} = $up;
17272							}
17273
17274	189 189					190 242	for my $network (@{ $domain->{networks} }) {
17275
17276							# Iterate over all interfaces attached to current network.
17277							# If interface is virtual tunnel for multiple software clients,
17278							# take separate rules for each software client.
17279	587 2					450 5	for my $interface (
17280	870 587	100				1618 753	map { $_->{id_rules} ? values %{ $_->{id_rules} } : $_ }
17281							@{ $network->{interfaces} })
17282							{
17283	873					789	my $router = $interface->{router};
17284	873	100				1567	my $managed = $router->{managed} or next;
17285	615					705	my $secondary_filter = $managed =~ /secondary$/;
17286	615					605	my $standard_filter = $managed eq 'standard';
17287	615					628	my $do_auth = $router->{model}->{do_auth};
17288	615	100				917	my $hardware =
17289							$interface->{ip} eq 'tunnel'
17290							? $interface
17291							: $interface->{hardware};
17292
17293							# Do local optimization only once for each hardware interface.
17294	615	100				1135	next if $seen{$hardware};
17295	574					828	$seen{$hardware} = 1;
17296
17297	574	100				969	if ($router->{model}->{filter} eq 'iptables') {
17298	60					94	find_chains $router, $hardware;
17299	60					130	next;
17300							}
17301
17302	514					678	remove_non_local_rules($router, $hardware);
17303
17304							# my $rname = $router->{name};
17305							# debug("$router->{name}");
17306	514					514	for my $rules ('intf_rules', 'rules', 'out_rules') {
17307
17308							# my $t1 = time();
17309
17310							# For supernet / aggregate rules used in optimization.
17311	1542					1112	my %hash;
17312
17313							# For finding duplicate rules having src or dst
17314							# which exist as different objects with identical
17315							# ip address.
17316							my %id_hash;
17317
17318							# For finding duplicate secondary rules.
17319	0					0	my %id_hash2;
17320
17321	1542					1138	my $changed = 0;
17322	1542 1542					1108 2351	for my $rule (@{ $hardware->{$rules} }) {
17323
17324							# Change rule to allow optimization of objects
17325							# having identical IP address.
17326	571					540	for my $what (qw(src dst)) {
17327	1142					1048	my $obj = $rule->{$what};
17328	1142					806	my $obj_changed;
17329
17330							# Change loopback interface to loopback network.
17331							# The loopback network is additionally checked
17332							# below.
17333	1142	100	67			1860	if ($obj->{loopback} &&
17334							(my $network = $obj->{network}))
17335							{
17336	14	100	67			45	if (!($rules eq 'intf_rules' && $what eq 'dst'))
17337							{
17338	8					5	$obj = $network;
17339	8					9	$obj_changed = 1;
17340							}
17341							}
17342
17343							# Identical networks from dynamic NAT and
17344							# from identical aggregates.
17345	1142	100 100				2162	if (my $identical = $obj->{is_identical}) {
17346	22	100				47	if (my $other = $identical->{$no_nat_set}) {
17347	19					20	$obj = $other;
17348	19					24	$obj_changed = 1;
17349							}
17350							}
17351
17352							# Identical redundancy interfaces.
17353							elsif (my $aref = $obj->{redundancy_interfaces}) {
17354	13	100	67 50			40	if (
17355							!($rules eq 'intf_rules' && $what eq 'dst')
17356							\|\| ( $router->{crosslink_intf_hash}
17357							&& $router->{crosslink_intf_hash}
17358							->{ $aref->[0] })
17359							)
17360							{
17361	11					11	$obj = $aref->[0];
17362	11					9	$obj_changed = 1;
17363							}
17364							}
17365
17366	1142	100				1978	$obj_changed or next;
17367
17368							# Don't change rules of devices in other
17369							# NAT domain where we may have other
17370							# relation.
17371	38					190	$rule = { %$rule, $what => $obj };
17372							}
17373	571					835	my ($src, $dst, $deny, $src_range, $prt) =
17374	571					555	@{$rule}{qw(src dst deny src_range prt)};
17375	571		50			1373	$deny \|\|= '';
17376	571		67			1199	$src_range \|\|= $prt_ip;
17377
17378							# Remove duplicate rules.
17379	571	100				2084	if ($id_hash{$deny}->{$src_range}->{$src}->{$dst}
17380							->{$prt})
17381							{
17382	43					40	$rule = undef;
17383	43					57	$changed = 1;
17384
17385							# $r2id{$rname}++;
17386	43					74	next;
17387							}
17388	528					1630	$id_hash{$deny}->{$src_range}->{$src}->{$dst}
17389							->{$prt} = $rule;
17390
17391	528	100	100			2438	if ( $src->{is_supernet}
17392							\|\| $dst->{is_supernet}
17393							\|\| $rule->{stateless})
17394							{
17395	188					805	$hash{$deny}->{$src_range}->{$src}->{$dst}
17396							->{$prt} = $rule;
17397							}
17398							}
17399
17400							# my $t2 = time();
17401							# $time{$rname}[0] += $t2-$t1;
17402							RULE:
17403	1542 1542					1237 1863	for my $rule (@{ $hardware->{$rules} }) {
17404	571	100				843	next if not $rule;
17405
17406							# my $t3 = time();
17407							# $r2rules{$rname}++;
17408
17409							# debug(print_rule $rule);
17410							# debug "is_supernet" if $rule->{dst}->{is_supernet};
17411	528					827	my ($deny, $src, $dst, $src_range, $prt, $log) =
17412	528					428	@{$rule}{qw(deny src dst src_range prt log)};
17413	528		50			1271	$deny \|\|= '';
17414	528		67			1105	$src_range \|\|= $prt_ip;
17415	528		100			1124	$log \|\|= '';
17416
17417	528					375	while (1) {
17418	1044					800	my $src_range = $src_range;
17419	1044	100				1549	if (my $hash = $hash{$deny}) {
17420	253					179	while (1) {
17421	267					211	my $src = $src;
17422	267	100				515	if (my $hash = $hash->{$src_range}) {
17423	253					190	while (1) {
17424	507					364	my $dst = $dst;
17425	507	100				874	if (my $hash = $hash->{$src}) {
17426	258					206	while (1) {
17427	524					382	my $prt = $prt;
17428	524	100				895	if (my $hash = $hash->{$dst}) {
17429	260					211	while (1) {
17430	676	100				1073	if (my $other_rule = $hash->{$prt}) {
17431	203		100			530	my $o_log = $other_rule->{log} \|\| '';
17432	203	100	100			530	if ($rule ne $other_rule && $log eq $o_log) {
17433
17434							# debug("del:", print_rule $rule);
17435							# debug("oth:", print_rule $other_rule);
17436	12					10	$rule = undef;
17437
17438							# $r2del{$rname}++;
17439	12					11	$changed = 1;
17440
17441							# $time{$rname}[1] += time()-$t3;
17442	12					44	next RULE;
17443							}
17444							}
17445	664	100				1042	$prt = $prt->{up} or last;
17446							}
17447							}
17448	512	100				825	$dst = $dst->{up} or last;
17449							}
17450							}
17451	495	100				791	$src = $src->{up} or last;
17452							}
17453							}
17454	255	100				456	$src_range = $src_range->{up} or last;
17455							}
17456							}
17457	1032	100				1385	last if $deny;
17458	516					441	$deny = 1;
17459							}
17460
17461							# my $t4 = time();
17462							# $time{$rname}[1] += $t4-$t3;
17463
17464							# Implement remaining rules as secondary rule,
17465							# if possible.
17466	516	100	71			2544	if ( $secondary_filter && $rule->{some_non_secondary}
17467							\|\| $standard_filter && $rule->{some_primary})
17468							{
17469	15	50				28	$rule->{deny} and internal_err();
17470	15 15					17 21	my ($src, $dst) = @{$rule}{qw(src dst)};
17471
17472							# Replace obj by largest supernet in zone,
17473							# which has no subnet in other zone.
17474							# We must not change to network having subnet in
17475							# other zone, because then we had to do
17476							# check_supernet_rules for newly created
17477							# secondary rules.
17478	15					26	for my $ref (\$src, \$dst) {
17479
17480							# Restrict secondary optimization at
17481							# authenticating router to prevent
17482							# unauthorized access with spoofed IP
17483							# address.
17484	30	50				51	if ($do_auth) {
17485	0					0	my $type = ref($$ref);
17486
17487							# Single ID-hosts must not be
17488							# converted to network.
17489	0	0 0				0	if ($type eq 'Subnet') {
17490	0	0				0	next if $$ref->{id};
17491							}
17492
17493							# Network with ID-hosts must not
17494							# be optimized at all.
17495							elsif ($type eq 'Network') {
17496	0	0				0	next RULE if $$ref->{has_id_hosts};
17497							}
17498							}
17499	30	50	40			86	if (
17500							$$ref eq $dst
17501							&& is_interface($dst)
17502							&& (
17503							$dst->{router} eq $router
17504							\|\| ( $router->{crosslink_intf_hash}
17505							and $router->{crosslink_intf_hash}
17506							->{$dst})
17507							)
17508							)
17509							{
17510	1					2	next;
17511							}
17512	29	100	67			45	if (is_subnet($$ref) \|\| is_interface($$ref)) {
17513	7					9	my $net = $$ref->{network};
17514	7	100				17	next if $net->{has_other_subnet};
17515	4					5	$$ref = $net;
17516							}
17517	26	100				50	if (my $max = $$ref->{max_secondary_net}) {
17518	3					5	$$ref = $max;
17519							}
17520
17521							# Prevent duplicate ACLs for networks which
17522							# are translated to the same ip address.
17523	26	50				56	if (my $identical = $$ref->{is_identical}) {
17524	0	0				0	if (my $one_net = $identical->{$no_nat_set})
17525							{
17526	0					0	$$ref = $one_net;
17527							}
17528							}
17529							}
17530
17531							# Add new rule to hash. If there are multiple
17532							# rules which could be converted to the same
17533							# secondary rule, only the first one will be
17534							# generated.
17535	15	50				46	if (my $old = $id_hash2{$src}->{$dst}) {
17536
17537	0	0				0	if ($old ne $rule) {
17538
17539							# debug("sec delete: ", print_rule $rule);
17540
17541	0					0	$rule = undef;
17542	0					0	$changed = 1;
17543
17544							# $r2sec{$rname}++;
17545							}
17546							}
17547							else {
17548
17549							# Don't modify original rule, because the
17550							# identical rule is referenced at different
17551							# routers.
17552	15					32	my $new_rule = {
17553							src => $src,
17554							dst => $dst,
17555							prt => $prt_ip,
17556							};
17557	15	50				30	$new_rule->{log} = $rule->{log} if $rule->{log};
17558
17559							# debug("sec: ", print_rule $new_rule);
17560	15					28	$id_hash2{$src}->{$dst} = $new_rule;
17561
17562							# This only works if smaller rule isn't
17563							# already processed.
17564	15	100	100			47	if ($src->{is_supernet} \|\| $dst->{is_supernet})
17565							{
17566	8					29	$hash{''}->{$prt_ip}->{$src}->{$dst}
17567							->{$prt_ip} = $new_rule;
17568							}
17569
17570							# This changes @{$hardware->{$rules}} !
17571	15					33	$rule = $new_rule;
17572							}
17573							}
17574
17575							# my $t5 = time();
17576							# $time{$rname}[2] += $t5-$t4;
17577							}
17578	1542	100				3426	if ($changed) {
17579	113					288	$hardware->{$rules} =
17580	38 38					43 59	[ grep { defined $_ } @{ $hardware->{$rules} } ];
17581							}
17582							}
17583
17584	514					761	add_local_deny_rules($router, $hardware);
17585
17586							# Join adjacent port ranges. This must be called after local
17587							# optimization has been finished, because protocols will be
17588							# overlapping again after joining.
17589							# my $t6 = time();
17590	514					631	join_ranges($router, $hardware);
17591
17592							# $time{$rname}[3] += time() - $t6;
17593							}
17594							}
17595							}
17596
17597							# my ($orules, $oid, $odel, $osec, $arules, $aid, $adel, $asec,
17598							# @otime, @atime);
17599							# my $f = '%-12s %7i %7i %7i %7i %.3f %.3f %.3f %.3f %.3f';
17600							# for my $aref (values %time) {
17601							# $aref->[4] = $aref->[0] + $aref->[1] + $aref->[2] + $aref->[3];
17602							# $atime[0] += $aref->[0];
17603							# $atime[1] += $aref->[1];
17604							# $atime[2] += $aref->[2];
17605							# $atime[3] += $aref->[3];
17606							# $atime[4] += $aref->[4];
17607							# }
17608							# for my $name (sort { $time{$a}[4] <=> $time{$b}[4] } keys %time) {
17609							# my $pre = $time{$name}[0];
17610							# my $while = $time{$name}[1];
17611							# my $secon = $time{$name}[2];
17612							# my $join = $time{$name}[3];
17613							# my $sum = $time{$name}[4];
17614							# my $rules = $r2rules{$name};
17615							# my $id = $r2id{$name} \|\| 0;
17616							# my $del = $r2del{$name} \|\| 0;
17617							# my $sec = $r2sec{$name} \|\| 0;
17618							# $arules += $rules;
17619							# $aid += $id;
17620							# $adel += $del;
17621							# $asec += $sec;
17622							# if ($sum < 0.5) {
17623							# $otime[0] += $pre;
17624							# $otime[1] += $while;
17625							# $otime[2] += $secon;
17626							# $otime[3] += $join;
17627							# $otime[4] += $sum;
17628							# $orules += $rules;
17629							# $odel += $del;
17630							# $oid += $id;
17631							# $osec += $sec;
17632							# }
17633							# else {
17634							# $name =~ s/^router://;
17635							# debug(sprintf( $f, $name, $rules, $id, $del, $sec,
17636							# $pre, $while, $secon, $join, $sum));
17637							# }
17638							# }
17639							# debug(sprintf( $f, 'other', $orules, $oid, $odel, $osec,
17640							# $otime[0], $otime[1], $otime[2], $otime[3], $otime[4]));
17641							# debug(sprintf( $f, 'all', $arules, $aid, $adel, $asec,
17642							# $atime[0], $atime[1], $atime[2], $atime[3], $atime[4]));
17643
17644	155					268	return;
17645							}
17646
17647							my $deny_any_rule;
17648
17649							sub print_cisco_acl_add_deny {
17650	481			481	0	582	my ($router, $hardware, $no_nat_set, $model, $prefix) = @_;
17651	481					357	my $permit_any;
17652
17653	481		50			785	my $rules = $hardware->{rules} \|\|= [];
17654	481	100				705	if (@$rules) {
17655	235					402	my ($deny, $src, $dst, $prt) =
17656	235					210	@{ $rules->[-1] }{ 'deny', 'src', 'dst', 'prt' };
17657	235		100			548	$permit_any =
17658							!$deny
17659							&& is_network($src)
17660							&& $src->{mask} == 0
17661							&& is_network($dst)
17662							&& $dst->{mask} == 0
17663							&& $prt eq $prt_ip;
17664							}
17665
17666							# Add permit or deny rule at end of ACL
17667							# unless the previous rule is 'permit ip any any'.
17668	481	100				703	if (!$permit_any) {
17669	447					852	push(
17670	447	100				343	@{ $hardware->{rules} },
17671							$hardware->{no_in_acl} ? $permit_any_rule : $deny_any_rule
17672							);
17673	447					459	$permit_any = $hardware->{no_in_acl};
17674							}
17675
17676	481	100	100			1161	if ($router->{need_protect} \|\|
17677
17678							# ASA protects IOS router behind crosslink interface.
17679							$router->{crosslink_intf_hash})
17680							{
17681
17682							# Routers connected by crosslink networks are handled like one
17683							# large router. Protect the collected interfaces of the whole
17684							# cluster at each entry.
17685	280					251	my $interfaces = $router->{crosslink_interfaces};
17686	280	100				405	if (!$interfaces) {
17687	262					239	$interfaces = $router->{interfaces};
17688	262	100				403	if ($model->{has_vip}) {
17689	7 15					10 28	$interfaces = [ grep { !$_->{vip} } @$interfaces ];
17690							}
17691							}
17692
17693							# Set crosslink_intf_hash even for routers not part of a
17694							# crosslink cluster.
17695	304					693	$router->{crosslink_intf_hash} \|\|=
17696	280 113		100			502 142	{ map { $_ => $_ } @{ $router->{interfaces} } };
17697	280					274	my $intf_hash = $router->{crosslink_intf_hash};
17698
17699							# Add deny rules to protect own interfaces.
17700							# If a rule permits traffic to a directly connected network
17701							# behind the device, this would accidently permit traffic
17702							# to an interface of this device as well.
17703
17704							# Deny rule is needless if there is a rule which permits any
17705							# traffic to the interface or
17706							# to one interface of a redundancy group.
17707							# The permit rule can be deleted if there is a permit any any rule.
17708	280					214	my %no_protect;
17709							my %seen;
17710	0					0	my $changed;
17711	280 280					225 404	for my $rule (@{ $hardware->{intf_rules} }) {
17712	62	50				102	next if $rule->{deny};
17713	62					54	my $src = $rule->{src};
17714	62	100				78	next if not is_network($src);
17715	53	100				125	next if $src->{mask} != 0;
17716	18	100				42	next if $rule->{prt} ne $prt_ip;
17717	9					10	my $dst = $rule->{dst};
17718	9	100				24	$no_protect{$dst} = 1 if $intf_hash->{$dst};
17719	9	50				14	$seen{ $dst->{redundancy_interfaces} }++
17720							if $dst->{redundancy_interfaces};
17721
17722	9	100				21	if ($permit_any) {
17723	5					4	$rule = undef;
17724	5					15	$changed = 1;
17725							}
17726							}
17727	280	100				415	if ($changed) {
17728	5					8	$hardware->{intf_rules} =
17729	3 3					4 5	[ grep { defined $_ } @{ $hardware->{intf_rules} } ];
17730							}
17731
17732							# Deny rule is needless if there is no such permit rule.
17733							# Try to optimize this case.
17734	280					211	my %need_protect;
17735							my $protect_all;
17736	280					432	my $local_filter = $router->{managed} =~ /^local/;
17737							my $check_intf = sub {
17738	97			97		97	my ($ip, $mask) = @_;
17739	97					161	for my $intf (values %$intf_hash) {
17740	247	100				573	next if $intf->{ip} =~
17741							/^(unnumbered\|negotiated\|tunnel\|bridged)$/;
17742	239					275	my $i = address($intf, $no_nat_set)->[0];
17743	239	100				338	if (match_ip($i, $ip, $mask)) {
17744	84					203	$need_protect{$intf} = $intf;
17745
17746							# debug("Protect $intf->{name} at $hardware->{name}");
17747							}
17748							}
17749	280					879	};
17750	280					353	RULE:
17751	280					262	for my $rule (@{ $hardware->{rules} }) {
17752	428	100				843	next if $rule->{deny};
17753	165	100				284	next if $rule->{prt}->{established};
17754
17755							# Ignore permit_any_rule of local filter.
17756							# Some other permit_any_rule from a real service
17757							# wouldn't match.
17758	140	100	100			312	next if $local_filter && $rule eq $permit_any_rule;
17759	133					116	my $dst = $rule->{dst};
17760
17761							# We only need to check networks:
17762							# - subnet/host and interface already have been checked to
17763							# have disjoint ip addresses to interfaces of current router.
17764	133	100 100				187	if (is_objectgroup($dst)) {
17765	1					2	my $elements = $dst->{elements};
17766	1					1	for my $ip_mask ( @$elements ) {
17767	3					7	my ($ip, $mask) = split '/', $ip_mask;
17768	3	50				7	next if $mask == 0xffffffff;
17769	3					4	$check_intf->($ip, $mask);
17770							}
17771							}
17772							elsif (is_network($dst)) {
17773	111	100				196	if ($dst->{mask} == 0) {
17774	17					16	$protect_all = 1;
17775
17776							# debug("Protect all $router->{name}: $hardware->{name}");
17777	17					27	last RULE;
17778							}
17779
17780	94 94					85 128	my ($ip, $mask) = @{ address($dst, $no_nat_set) };
17781	94					159	$check_intf->($ip, $mask);
17782							}
17783							}
17784
17785	280					342	for my $interface (@$interfaces) {
17786	818	100	100 67			4411	if (
17787							$no_protect{$interface}
17788							or not $protect_all
17789							and not $need_protect{$interface}
17790
17791							# Interface with 'no_in_acl' gets 'permit any any' added
17792							# and hence needs deny rules.
17793							and not $hardware->{no_in_acl}
17794							)
17795							{
17796	700					824	next;
17797							}
17798
17799							# Ignore 'unnumbered' interfaces.
17800	118	50				272	if ($interface->{ip} =~
17801							/^(?:unnumbered\|negotiated\|tunnel\|bridged)$/)
17802							{
17803	0					0	next;
17804							}
17805	118	50				191	internal_err("Managed router has short $interface->{name}")
17806							if $interface->{ip} eq 'short';
17807
17808							# IP of other interface may be unknown if dynamic NAT is used.
17809	118	100				231	if ($interface->{hardware} ne $hardware) {
17810	100					140	my $nat_network =
17811							get_nat_network($interface->{network}, $no_nat_set);
17812	100	50				184	next if $nat_network->{dynamic};
17813							}
17814	118	50	67			236	if ( $interface->{redundancy_interfaces}
17815							and $seen{ $interface->{redundancy_interfaces} }++)
17816							{
17817	0					0	next;
17818							}
17819
17820							# Protect own interfaces.
17821	118 118					101 390	push @{ $hardware->{intf_rules} },
17822							{
17823							deny => 1,
17824							src => $network_00,
17825							dst => $interface,
17826							prt => $prt_ip
17827							};
17828							}
17829	280	100				1329	if ($hardware->{crosslink}) {
17830	2					8	$hardware->{intf_rules} = [];
17831							}
17832							}
17833
17834							# ASA and PIX ignore rules for own interfaces.
17835							else {
17836	201					275	$hardware->{intf_rules} = [];
17837							}
17838
17839							# Concatenate interface rules and ordinary rules.
17840	481					502	my $intf_rules = $hardware->{intf_rules};
17841	481	100				708	my $all_rules = @$intf_rules? [ @$intf_rules, @$rules ] : $rules;
17842	481					697	cisco_acl_line($router, $all_rules, $no_nat_set, $prefix);
17843	481					604	return;
17844							}
17845
17846							# Parameter: Interface
17847							# Analyzes dst of all rules collected at this interface.
17848							# Result:
17849							# Array reference to list of all networks which are allowed
17850							# to pass this interface.
17851							sub get_split_tunnel_nets {
17852	4			4	0	4	my ($interface) = @_;
17853
17854	4					4	my %split_tunnel_nets;
17855	4 4 4					3 5 7	for my $rule (@{ $interface->{rules} }, @{ $interface->{intf_rules} }) {
17856	11	50				16	next if $rule->{deny};
17857	11					15	my $dst = $rule->{dst};
17858	11	100				12	my $dst_network = is_network($dst) ? $dst : $dst->{network};
17859
17860							# Dont add 'any' (resulting from global:permit)
17861							# to split_tunnel networks.
17862	11	100				18	next if $dst_network->{mask} == 0;
17863	10					20	$split_tunnel_nets{$dst_network} = $dst_network;
17864							}
17865	4 5	50				10 14	return [ sort { $a->{ip} <=> $b->{ip} \|\| $a->{mask} <=> $b->{mask} }
17866							values %split_tunnel_nets ];
17867							}
17868
17869							my %asa_vpn_attr_need_value =
17870							map { $_ => 1 }
17871							qw(banner dns-server default-domain split-dns wins-server address-pools
17872							split-tunnel-network-list vpn-filter);
17873
17874							sub print_asavpn {
17875	3			3	0	3	my ($router) = @_;
17876	3					4	my $model = $router->{model};
17877	3					5	my $no_nat_set = $router->{hardware}->[0]->{no_nat_set};
17878
17879	3					2	my $global_group_name = 'global';
17880	3					7	print <<"EOF";
17881							group-policy $global_group_name internal
17882							group-policy $global_group_name attributes
17883							pfs enable
17884
17885							EOF
17886
17887							# Define tunnel group used for single VPN users.
17888	3					3	my $default_tunnel_group = 'VPN-single';
17889	3					4	my $trust_point = $router->{trust_point};
17890
17891	3					15	print <<"EOF";
17892							tunnel-group $default_tunnel_group type remote-access
17893							tunnel-group $default_tunnel_group general-attributes
17894							authorization-server-group LOCAL
17895							default-group-policy $global_group_name
17896							authorization-required
17897							username-from-certificate EA
17898							tunnel-group $default_tunnel_group ipsec-attributes
17899							chain
17900							EOF
17901
17902	3	50				4	if ($model->{v8_4}) {
17903	0					0	print <<"EOF";
17904							ikev1 trust-point $trust_point
17905							ikev1 user-authentication none
17906							tunnel-group $default_tunnel_group webvpn-attributes
17907							authentication certificate
17908							EOF
17909							}
17910							else {
17911	3					9	print <<"EOF";
17912							trust-point $trust_point
17913							isakmp ikev1-user-authentication none
17914							EOF
17915							}
17916	3					4	print <<"EOF";
17917							tunnel-group-map default-group $default_tunnel_group
17918
17919							EOF
17920
17921							my $print_group_policy = sub {
17922	4			4		4	my ($name, $attributes) = @_;
17923	4					8	print "group-policy $name internal\n";
17924	4					5	print "group-policy $name attributes\n";
17925	4					12	for my $key (sort keys %$attributes) {
17926	10					12	my $value = $attributes->{$key};
17927	10					10	my $out = $key;
17928	10	50				12	if (defined($value)) {
17929	10	100				20	$out .= ' value' if $asa_vpn_attr_need_value{$key};
17930	10					13	$out .= " $value";
17931							}
17932	10					22	print " $out\n";
17933							}
17934	3					13	};
17935
17936	3					4	my %cert_group_map;
17937							my %single_cert_map;
17938	3					3	my $user_counter = 0;
17939	3 3					3 4	for my $interface (@{ $router->{interfaces} }) {
17940	8	100				14	next if not $interface->{ip} eq 'tunnel';
17941	3					3	my %split_t_cache;
17942
17943	3	100				5	if (my $hash = $interface->{id_rules}) {
17944	2					11	for my $id (sort keys %$hash) {
17945	5					6	my $id_intf = $hash->{$id};
17946	5					5	my $src = $id_intf->{src};
17947	5					4	$user_counter++;
17948	5					5	my $pool_name;
17949	5					8	my $attributes = {
17950	5					8	%{ $router->{radius_attributes} },
17951	5					15	%{ $src->{network}->{radius_attributes} },
17952	5					3	%{ $src->{radius_attributes} },
17953							};
17954
17955							# Define split tunnel ACL.
17956							# Use default value if not defined.
17957	5					6	my $split_tunnel_policy = $attributes->{'split-tunnel-policy'};
17958	5	100 50 50				10	if (not defined $split_tunnel_policy) {
17959
17960							# Do nothing.
17961							}
17962							elsif ($split_tunnel_policy eq 'tunnelall') {
17963
17964							# This is the default value.
17965							# Prevent new group-policy to be created.
17966	0					0	delete $attributes->{'split-tunnel-policy'};
17967							}
17968							elsif ($split_tunnel_policy eq 'tunnelspecified') {
17969	1					3	my $split_tunnel_nets = get_split_tunnel_nets($id_intf);
17970	1					2	my $acl_name;
17971	1	50				3	if (my $href = $split_t_cache{@$split_tunnel_nets}) {
17972							CACHED_NETS:
17973	0					0	for my $cached_name (keys %$href) {
17974	0					0	my $cached_nets = $href->{$cached_name};
17975	0					0	for (my $i = 0 ; $i < @$cached_nets ; $i++) {
17976	0	0				0	if ($split_tunnel_nets->[$i] ne
17977							$cached_nets->[$i])
17978							{
17979	0					0	next CACHED_NETS;
17980							}
17981							}
17982	0					0	$acl_name = $cached_name;
17983	0					0	last;
17984							}
17985							}
17986	1	50				2	if (not $acl_name) {
17987	1					1	$acl_name = "split-tunnel-$user_counter";
17988	1	50				2	if (@$split_tunnel_nets) {
17989	1					2	for my $network (@$split_tunnel_nets) {
17990	4					6	my $line =
17991							"access-list $acl_name standard permit ";
17992	4					5	$line .=
17993							cisco_acl_addr(address($network,
17994							$no_nat_set),
17995							$model);
17996	4					10	print "$line\n";
17997							}
17998							}
17999							else {
18000	0					0	print "access-list $acl_name standard deny any\n";
18001							}
18002	1					3	$split_t_cache{@$split_tunnel_nets}->{$acl_name} =
18003							$split_tunnel_nets;
18004							}
18005	1					2	$attributes->{'split-tunnel-network-list'} = $acl_name;
18006							}
18007
18008							# Access list will be bound to cleartext interface.
18009							# Only check for valid source address at vpn-filter.
18010	5					7	$id_intf->{intf_rules} = [];
18011	5					11	$id_intf->{rules} = [
18012							{
18013							src => $src,
18014							dst => $network_00,
18015							prt => $prt_ip,
18016							}
18017							];
18018	5					12	find_object_groups($router, $id_intf);
18019
18020							# Define filter ACL to be used in username or group-policy.
18021	5					7	my $filter_name = "vpn-filter-$user_counter";
18022	5					8	my $prefix = "access-list $filter_name extended";
18023	5					9	print_cisco_acl_add_deny $router, $id_intf, $no_nat_set, $model,
18024							$prefix;
18025
18026	5					5	my $ip = print_ip $src->{ip};
18027	5					5	my $network = $src->{network};
18028	5	100				14	if ($src->{mask} == 0xffffffff) {
18029
18030							# For anyconnect clients.
18031	3	50				6	if ($model->{v8_4}) {
18032	0					0	my ($name, $domain) = ($id =~ /^(.?)(\@.)$/);
18033	0					0	$single_cert_map{$domain} = 1;
18034							}
18035
18036	3					4	my $mask = print_ip $network->{mask};
18037	3					3	my $group_policy_name;
18038	3	100				6	if (%$attributes) {
18039	2					2	$group_policy_name = "VPN-group-$user_counter";
18040	2					3	$print_group_policy->($group_policy_name, $attributes);
18041							}
18042	3					8	print "username $id nopassword\n";
18043	3					5	print "username $id attributes\n";
18044	3					6	print " vpn-framed-ip-address $ip $mask\n";
18045	3					4	print " service-type remote-access\n";
18046	3					5	print " vpn-filter value $filter_name\n";
18047	3	100				7	print " vpn-group-policy $group_policy_name\n"
18048							if $group_policy_name;
18049	3					9	print "\n";
18050							}
18051							else {
18052	2					4	$pool_name = "pool-$user_counter";
18053	2					3	my $mask = print_ip $src->{mask};
18054	2					4	my $max =
18055							print_ip($src->{ip} \| complement_32bit $src->{mask});
18056	2					2	my $subject_name = delete $attributes->{'check-subject-name'};
18057	2	100				7	if ($id =~ /^@/) {
18058	1					2	$subject_name = 'ea';
18059							}
18060	2					3	my $map_name = "ca-map-$user_counter";
18061	2					4	print "crypto ca certificate map $map_name 10\n";
18062	2					5	print " subject-name attr $subject_name co $id\n";
18063	2					9	print "ip local pool $pool_name $ip-$max mask $mask\n";
18064	2					3	$attributes->{'vpn-filter'} = $filter_name;
18065	2					2	$attributes->{'address-pools'} = $pool_name;
18066	2					3	my $group_policy_name = "VPN-group-$user_counter";
18067	2					4	my @tunnel_gen_att =
18068							("default-group-policy $group_policy_name");
18069
18070							# Select attributes for tunnel-group general-attributes.
18071	2					9	for my $key (sort keys %$attributes) {
18072	10					9	my $spec = $asa_vpn_attributes{$key};
18073	10	50	67			28	if ($spec && $spec->{tg_general}) {
18074	0					0	my $value = delete $attributes->{$key};
18075	0	0				0	my $out = defined($value) ? "$key $value" : $key;
18076	0					0	push(@tunnel_gen_att, $out);
18077							}
18078							}
18079
18080	2		33			7	my $trustpoint2 = delete $attributes->{'trust-point'}
18081							\|\| $trust_point;
18082	2	50				6	my @tunnel_ipsec_att =
18083							$model->{v8_4}
18084							? (
18085							"ikev1 trust-point $trustpoint2",
18086							'ikev1 user-authentication none'
18087							)
18088							: (
18089							"trust-point $trustpoint2",
18090							'isakmp ikev1-user-authentication none'
18091							);
18092
18093	2					4	$print_group_policy->($group_policy_name, $attributes);
18094
18095	2					3	my $tunnel_group_name = "VPN-tunnel-$user_counter";
18096	2					5	print <<"EOF";
18097							tunnel-group $tunnel_group_name type remote-access
18098							tunnel-group $tunnel_group_name general-attributes
18099							EOF
18100
18101	2					2	for my $line (@tunnel_gen_att) {
18102	2					5	print " $line\n";
18103							}
18104	2					4	print <<"EOF";
18105							tunnel-group $tunnel_group_name ipsec-attributes
18106							EOF
18107
18108	2					1	for my $line (@tunnel_ipsec_att) {
18109	4					9	print " $line\n";
18110							}
18111
18112							# For anyconnect clients.
18113	2	50				4	if ($model->{v8_4}) {
18114	0					0	print <<"EOF";
18115							tunnel-group $tunnel_group_name webvpn-attributes
18116							authentication certificate
18117							EOF
18118	0					0	$cert_group_map{$map_name} = $tunnel_group_name;
18119							}
18120
18121	2					9	print <<"EOF";
18122							tunnel-group-map ca-map-$user_counter 10 $tunnel_group_name
18123
18124							EOF
18125							}
18126							}
18127							}
18128
18129							# A VPN network.
18130							else {
18131	1					1	$user_counter++;
18132
18133							# Access list will be bound to cleartext interface.
18134							# Only check for correct source address at vpn-filter.
18135	1					2	$interface->{intf_rules} = [];
18136	2					5	$interface->{rules} = [
18137							map {
18138	1					3	{
18139							src => $_,
18140							dst => $network_00,
18141							prt => $prt_ip,
18142							}
18143	1					1	} @{ $interface->{peer_networks} }
18144							];
18145	1					3	find_object_groups($router, $interface);
18146
18147							# Define filter ACL to be used in username or group-policy.
18148	1					3	my $filter_name = "vpn-filter-$user_counter";
18149	1					2	my $prefix = "access-list $filter_name extended";
18150
18151	1					2	print_cisco_acl_add_deny $router, $interface, $no_nat_set, $model,
18152							$prefix;
18153
18154	1	50				3	my $id = $interface->{peers}->[0]->{id}
18155							or internal_err("Missing ID at $interface->{peers}->[0]->{name}");
18156	1					2	my $attributes = $router->{radius_attributes};
18157
18158	1					1	my $group_policy_name;
18159	1	50				3	if (keys %$attributes) {
18160	0					0	$group_policy_name = "VPN-router-$user_counter";
18161	0					0	$print_group_policy->($group_policy_name, $attributes);
18162							}
18163	1					3	print "username $id nopassword\n";
18164	1					2	print "username $id attributes\n";
18165	1					5	print " service-type remote-access\n";
18166	1					2	print " vpn-filter value $filter_name\n";
18167	1	50				3	print " vpn-group-policy $group_policy_name\n"
18168							if $group_policy_name;
18169	1					3	print "\n";
18170							}
18171							}
18172
18173							# Generate certificate-group-map for anyconnect/ikev2 clients.
18174	3	50	33			15	if (keys %cert_group_map or keys %single_cert_map) {
18175	0					0	for my $id (sort keys %single_cert_map) {
18176	0					0	$user_counter++;
18177	0					0	my $map_name = "ca-map-$user_counter";
18178	0					0	print "crypto ca certificate map $map_name 10\n";
18179	0					0	print " subject-name attr ea co $id\n";
18180	0					0	$cert_group_map{$map_name} = $default_tunnel_group;
18181							}
18182	0					0	print "webvpn\n";
18183	0					0	for my $map_name (sort keys %cert_group_map) {
18184	0					0	my $tunnel_group_map = $cert_group_map{$map_name};
18185	0					0	print " certificate-group-map $map_name 10 $tunnel_group_map\n";
18186							}
18187							}
18188	3					15	return;
18189							}
18190
18191							sub iptables_acl_line {
18192	53			53	0	60	my ($rule, $no_nat_set, $prefix) = @_;
18193	53					98	my ($action, $src, $dst, $src_range, $prt) =
18194	53					43	@{$rule}{qw(action src dst src_range prt)};
18195	53					68	my $spair = address($src, $no_nat_set);
18196	53					64	my $dpair = address($dst, $no_nat_set);
18197	53	50 100				70	my $action_code =
18198							is_chain($action) ? $action->{name}
18199							: $action eq 'permit' ? 'ACCEPT'
18200							: 'droplog';
18201	53	100				79	my $jump = $rule->{goto} ? '-g' : '-j';
18202	53					127	my $result = "$prefix $jump $action_code";
18203	53	100				111	if ($spair->[1] != 0) {
18204	35					48	$result .= ' -s ' . prefix_code($spair);
18205							}
18206	53	100				97	if ($dpair->[1] != 0) {
18207	42					52	$result .= ' -d ' . prefix_code($dpair);
18208							}
18209	53	100				118	if ($prt ne $prt_ip) {
18210	49					65	$result .= ' ' . iptables_prt_code($src_range, $prt);
18211							}
18212	53					103	print "$result\n";
18213	53					159	return;
18214							}
18215
18216							# Pre-processing for all interfaces.
18217							sub print_acl_prefix {
18218	246			246	0	1263	my ($router) = @_;
18219	246					263	my $model = $router->{model};
18220	246	100				474	return if $model->{filter} ne 'iptables';
18221	33					30	my $comment_char = $model->{comment_char};
18222	33					56	print "$comment_char [ PREFIX ]\n";
18223	33					41	print "#!/sbin/iptables-restore <<EOF\n";
18224
18225							# Excempt loopback packets from connection tracking.
18226	33					34	print "*raw\n";
18227	33					36	print ":PREROUTING ACCEPT\n";
18228	33					33	print ":OUTPUT ACCEPT\n";
18229	33					36	print "-A PREROUTING -i lo -j NOTRACK\n";
18230	33					36	print "-A OUTPUT -o lo -j NOTRACK\n";
18231	33					28	print "COMMIT\n";
18232
18233							# Start filter table
18234	33					29	print "*filter\n";
18235	33					34	print ":INPUT DROP\n";
18236	33					31	print ":FORWARD DROP\n";
18237	33					33	print ":OUTPUT ACCEPT\n";
18238	33					36	print "-A INPUT -j ACCEPT -m state --state ESTABLISHED,RELATED\n";
18239	33					33	print "-A FORWARD -j ACCEPT -m state --state ESTABLISHED,RELATED\n";
18240	33					33	print "-A INPUT -j ACCEPT -i lo\n";
18241
18242							# Add user defined chain 'droplog'.
18243	33					32	print ":droplog -\n";
18244	33					37	print "-A droplog -j LOG --log-level debug\n";
18245	33					30	print "-A droplog -j DROP\n";
18246	33					29	print "\n";
18247	33					37	return;
18248							}
18249
18250							sub print_acl_suffix {
18251	246			246	0	249	my ($router) = @_;
18252	246					260	my $model = $router->{model};
18253	246	100				489	return if $model->{filter} ne 'iptables';
18254	33					32	my $comment_char = $model->{comment_char};
18255	33					52	print "$comment_char [ SUFFIX ]\n";
18256	33					33	print "-A INPUT -j droplog\n";
18257	33					34	print "-A FORWARD -j droplog\n";
18258	33					30	print "COMMIT\n";
18259	33					30	print "EOF\n";
18260	33					31	return;
18261							}
18262
18263							sub print_iptables_acls {
18264	34			34	0	34	my ($router) = @_;
18265	34					32	my $model = $router->{model};
18266	34					29	my $comment_char = $model->{comment_char};
18267
18268	34					48	print_chains $router;
18269
18270	34 34					27 50	for my $hardware (@{ $router->{hardware} }) {
18271
18272							# Ignore if all logical interfaces are loopback interfaces.
18273	60	100				98	next if $hardware->{loopback};
18274
18275	58					67	my $in_hw = $hardware->{name};
18276	58					53	my $no_nat_set = $hardware->{no_nat_set};
18277	58	50				98	if ($config{comment_acls}) {
18278
18279							# Name of first logical interface
18280	0					0	print "$comment_char $hardware->{interfaces}->[0]->{name}\n";
18281							}
18282
18283							# Print chain and declaration for interface rules.
18284							# Add call to chain in INPUT chain.
18285	58					85	my $intf_acl_name = "${in_hw}_self";
18286	58					108	print ":$intf_acl_name -\n";
18287	58					118	print "-A INPUT -j $intf_acl_name -i $in_hw\n";
18288	58					77	my $intf_prefix = "-A $intf_acl_name";
18289	58 58					50 98	for my $rule (@{ $hardware->{intf_rules} }) {
18290	28					39	iptables_acl_line($rule, $no_nat_set, $intf_prefix);
18291							}
18292
18293							# Print chain and declaration for forward rules.
18294							# Add call to chain in FORRWARD chain.
18295							# One chain for each pair of in_intf / out_intf.
18296	58					55	my $rules_hash = $hardware->{io_rules};
18297	58					131	for my $out_hw (sort keys %$rules_hash) {
18298	22					32	my $acl_name = "${in_hw}_$out_hw";
18299	22					43	print ":$acl_name -\n";
18300	22					57	print "-A FORWARD -j $acl_name -i $in_hw -o $out_hw\n";
18301	22					31	my $prefix = "-A $acl_name";
18302	22					30	my $rules_aref = $rules_hash->{$out_hw};
18303	22					26	for my $rule (@$rules_aref) {
18304	25					41	iptables_acl_line($rule, $no_nat_set, $prefix, $model);
18305							}
18306							}
18307
18308							# Empty line after each chain.
18309	58					117	print "\n";
18310							}
18311	34					47	return;
18312							}
18313
18314							sub print_cisco_acls {
18315	214			214	0	193	my ($router) = @_;
18316	214					220	my $model = $router->{model};
18317	214					208	my $filter = $model->{filter};
18318	214					195	my $comment_char = $model->{comment_char};
18319
18320	214 214					174 305	for my $hardware (@{ $router->{hardware} }) {
18321
18322							# Ignore if all logical interfaces are loopback interfaces.
18323	499	100				820	next if $hardware->{loopback};
18324
18325							# Ignore layer3 interface of ASA.
18326	486	100	67			935	next if $hardware->{name} eq 'device' && $model->{class} eq 'ASA';
18327
18328							# Force valid array reference to prevent error
18329							# when checking for non empty array.
18330	481		100			782	$hardware->{rules} \|\|= [];
18331
18332	481	100				713	if ($model->{can_objectgroup}) {
18333	244	50				361	if (not $router->{no_group_code}) {
18334	244					416	find_object_groups($router, $hardware);
18335							}
18336							}
18337
18338	481					447	my $no_nat_set = $hardware->{no_nat_set};
18339
18340							# Generate code for incoming and possibly for outgoing ACL.
18341	481					490	for my $suffix ('in', 'out') {
18342	962	100	100			2969	next if $suffix eq 'out' and not $hardware->{need_out_acl};
18343
18344							# Don't generate single 'permit ip any any'.
18345	496	100				806	if (!$model->{need_acl}) {
18346	289 578	100	50			296 930	if (!grep { my $rules = $hardware->{$_} \|\| [];
18347	578	100				1772	@$rules != 1 \|\| $rules->[0] ne $permit_any_rule }
18348							(qw(rules intf_rules)))
18349							{
18350	8					8	next;
18351							}
18352							}
18353
18354	488					1008	my $acl_name = "$hardware->{name}_$suffix";
18355	488					456	my $prefix;
18356	488	50				782	if ($config{comment_acls}) {
18357
18358							# Name of first logical interface
18359	0					0	print "$comment_char $hardware->{interfaces}->[0]->{name}\n";
18360							}
18361	488	100 100 100 50				1017	if ($filter eq 'IOS') {
18362	246					221	$prefix = '';
18363	246					492	print "ip access-list extended $acl_name\n";
18364							}
18365							elsif ($filter eq 'NX-OS') {
18366	27					27	$prefix = '';
18367	27					69	print "ip access-list $acl_name\n";
18368							}
18369							elsif ($filter eq 'ACE') {
18370	8					16	$prefix = "access-list $acl_name extended";
18371							}
18372							elsif ($filter eq 'PIX') {
18373	207					209	$prefix = "access-list $acl_name";
18374	207	100				434	$prefix .= ' extended' if $model->{class} eq 'ASA';
18375							}
18376
18377							# Incoming ACL and protect own interfaces.
18378	488	100				630	if ($suffix eq 'in') {
18379	473					675	print_cisco_acl_add_deny(
18380							$router, $hardware, $no_nat_set, $model, $prefix
18381							);
18382							}
18383
18384							# Outgoing ACL
18385							else {
18386	15		50			32	my $out_rules = $hardware->{out_rules} \|\|= [];
18387
18388							# Add deny rule at end of ACL if not 'permit ip any any'
18389	15	100	100			46	if (!(@$out_rules && $out_rules->[-1] eq $permit_any_rule)) {
18390	14					17	push(@$out_rules, $deny_any_rule);
18391							}
18392	15					23	cisco_acl_line($router, $out_rules, $no_nat_set, $prefix);
18393							}
18394
18395							# Post-processing for hardware interface
18396	488	100 100 50	100			1509	if ($filter eq 'IOS' \|\| $filter eq 'NX-OS') {
18397	273					921	push(
18398	273					235	@{ $hardware->{subcmd} },
18399							"ip access-group $acl_name $suffix"
18400							);
18401							}
18402							elsif ($filter eq 'ACE') {
18403	8					25	push(
18404	8					9	@{ $hardware->{subcmd} },
18405							"access-group ${suffix}put $acl_name"
18406							);
18407							}
18408							elsif ($filter eq 'PIX') {
18409	207					712	print "access-group $acl_name $suffix interface",
18410							" $hardware->{name}\n";
18411							}
18412
18413							# Empty line after each ACL.
18414	488					794	print "\n";
18415							}
18416							}
18417	214					272	return;
18418							}
18419
18420							sub print_acls {
18421	248			248	0	221	my ($router) = @_;
18422	248					241	my $model = $router->{model};
18423	248					253	my $filter = $model->{filter};
18424	248					236	my $comment_char = $model->{comment_char};
18425	248					340	print_header($router, 'ACL');
18426
18427	248	100				344	if ($filter eq 'iptables') {
18428	34					47	print_iptables_acls($router);
18429							}
18430							else {
18431	214					278	print_cisco_acls($router);
18432							}
18433	248					435	return;
18434							}
18435
18436							sub gen_crypto_rules {
18437	10			10	0	9	my ($local, $remote) = @_;
18438	10					8	my @crypto_rules;
18439	10					11	for my $src (@$local) {
18440	11					9	for my $dst (@$remote) {
18441	14					44	push(
18442							@crypto_rules,
18443							{
18444							src => $src,
18445							dst => $dst,
18446							prt => $prt_ip
18447							}
18448							);
18449							}
18450							}
18451	10					17	return \@crypto_rules;
18452							}
18453
18454							sub print_ezvpn {
18455	1			1	0	1	my ($router) = @_;
18456	1					2	my $model = $router->{model};
18457	1 1					1 2	my @interfaces = @{ $router->{interfaces} };
18458	1 4					1 7	my @tunnel_intf = grep { $_->{ip} eq 'tunnel' } @interfaces;
18459	1	50				2	@tunnel_intf == 1 or internal_err();
18460	1					2	my ($tunnel_intf) = @tunnel_intf;
18461	1					1	my $wan_intf = $tunnel_intf->{real_interface};
18462	1					1	my $wan_hw = $wan_intf->{hardware};
18463	1					2	my $no_nat_set = $wan_hw->{no_nat_set};
18464	1 4	100				1 15	my @lan_intf = grep { $_ ne $wan_intf and $_ ne $tunnel_intf } @interfaces;
18465
18466							# Ezvpn configuration.
18467	1					2	my $ezvpn_name = 'vpn';
18468	1					1	my $crypto_acl_name = 'ACL-Split-Tunnel';
18469	1					1	my $crypto_filter_name = 'ACL-crypto-filter';
18470	1					1	my $virtual_interface_number = 1;
18471	1					3	print "crypto ipsec client ezvpn $ezvpn_name\n";
18472	1					1	print " connect auto\n";
18473	1					1	print " mode network-extension\n";
18474
18475	1 1					1 2	for my $peer (@{ $tunnel_intf->{peers} }) {
18476
18477							# Unnumbered, negotiated and short interfaces have been
18478							# rejected already.
18479	1					3	my $peer_ip = prefix_code(address($peer->{real_interface},
18480							$no_nat_set));
18481	1					4	print " peer $peer_ip\n";
18482							}
18483
18484							# Bind split tunnel ACL.
18485	1					2	print " acl $crypto_acl_name\n";
18486
18487							# Use virtual template defined above.
18488	1					3	print " virtual-interface $virtual_interface_number\n";
18489
18490							# xauth is unused, but syntactically needed.
18491	1					1	print " username test pass test\n";
18492	1					1	print " xauth userid mode local\n";
18493
18494							# Apply ezvpn to WAN and LAN interface.
18495	1					2	for my $lan_intf (@lan_intf) {
18496	2					3	my $lan_hw = $lan_intf->{hardware};
18497	2					6	push(
18498	2					1	@{ $lan_hw->{subcmd} },
18499							"crypto ipsec client ezvpn $ezvpn_name inside"
18500							);
18501							}
18502	1 1					1 3	push(@{ $wan_hw->{subcmd} }, "crypto ipsec client ezvpn $ezvpn_name");
18503
18504							# Crypto ACL controls which traffic needs to be encrypted.
18505	1	50				3	$tunnel_intf->{crypto}->{detailed_crypto_acl}
18506							and internal_err("Unexpected attribute 'detailed_crypto_acl'",
18507							" at $router->{name}");
18508	1					3	my $crypto_rules =
18509							gen_crypto_rules($tunnel_intf->{peers}->[0]->{peer_networks},
18510							[$network_00]);
18511	1					3	print "ip access-list extended $crypto_acl_name\n";
18512	1					1	my $prefix = '';
18513	1					2	cisco_acl_line($router, $crypto_rules, $no_nat_set, $prefix);
18514
18515							# Crypto filter ACL.
18516	1					1	$prefix = '';
18517	1		50			3	$tunnel_intf->{intf_rules} \|\|= [];
18518	1		50			7	$tunnel_intf->{rules} \|\|= [];
18519	1					2	print "ip access-list extended $crypto_filter_name\n";
18520	1					2	print_cisco_acl_add_deny($router, $tunnel_intf, $no_nat_set, $model,
18521							$prefix);
18522
18523							# Bind crypto filter ACL to virtual template.
18524	1					2	print "interface Virtual-Template$virtual_interface_number type tunnel\n";
18525	1	50				4	$crypto_filter_name
18526							and print " ip access-group $crypto_filter_name in\n";
18527	1					3	return;
18528							}
18529
18530							# Print crypto ACL.
18531							# It controls which traffic needs to be encrypted.
18532							sub print_crypto_acl {
18533	9			9	0	10	my ($interface, $suffix, $crypto, $crypto_type) = @_;
18534	9					12	my $crypto_acl_name = "crypto-$suffix";
18535	9					8	my $prefix;
18536	9	100 50				17	if ($crypto_type eq 'IOS') {
18537	1					1	$prefix = '';
18538	1					3	print "ip access-list extended $crypto_acl_name\n";
18539							}
18540							elsif ($crypto_type eq 'ASA') {
18541	8					15	$prefix = "access-list $crypto_acl_name extended";
18542							}
18543							else {
18544	0					0	internal_err();
18545							}
18546
18547							# Print crypto ACL entries.
18548							# - either generic from remote network to any or
18549							# - detailed to all networks which are used in rules.
18550	9					9	my $is_hub = $interface->{is_hub};
18551	9	100				13	my $hub = $is_hub ? $interface : $interface->{peers}->[0];
18552	9					10	my $detailed = $crypto->{detailed_crypto_acl};
18553	9	100				15	my $local = $detailed ? get_split_tunnel_nets($hub) : [$network_00];
18554	9					8	my $remote = $hub->{peer_networks};
18555	9	100				18	$is_hub or ($local, $remote) = ($remote, $local);
18556	9					11	my $crypto_rules = gen_crypto_rules($local, $remote);
18557	9					11	my $router = $interface->{router};
18558	9					7	my $no_nat_set = $interface->{no_nat_set};
18559	9					14	cisco_acl_line($router, $crypto_rules, $no_nat_set, $prefix);
18560	9					24	return $crypto_acl_name;
18561							}
18562
18563							# Print filter ACL. It controls which traffic is allowed to leave from
18564							# crypto tunnel. This may be needed, if we don't fully trust our peer.
18565							sub print_crypto_filter_acl {
18566	9			9	0	11	my ($interface, $suffix, $crypto_type) = @_;
18567	9					9	my $router = $interface->{router};
18568
18569	9	100				17	return if $router->{no_crypto_filter};
18570
18571	1					2	my $prefix;
18572	1					2	my $crypto_filter_name = "crypto-filter-$suffix";
18573	1	50				2	if ($crypto_type eq 'IOS') {
18574	1					1	$prefix = '';
18575	1					3	print "ip access-list extended $crypto_filter_name\n";
18576							}
18577							else {
18578	0					0	internal_err();
18579							}
18580	1					2	my $model = $router->{model};
18581	1					1	my $no_nat_set = $interface->{no_nat_set};
18582	1					2	print_cisco_acl_add_deny($router, $interface, $no_nat_set, $model, $prefix);
18583	1					6	return $crypto_filter_name;
18584							}
18585
18586							# Called for static and dynamic crypto maps.
18587							sub print_crypto_map_attributes {
18588	9			9	0	16	my ($prefix, $model, $crypto_type, $crypto_acl_name, $crypto_filter_name,
18589							$isakmp, $ipsec, $ipsec2trans_name) = @_;
18590
18591							# Bind crypto ACL to crypto map.
18592	9					20	print "$prefix match address $crypto_acl_name\n";
18593
18594							# Bind crypto filter ACL to crypto map.
18595	9	100				18	if ($crypto_filter_name) {
18596	1					3	print "$prefix set ip access-group $crypto_filter_name in\n";
18597							}
18598
18599	9					12	my $transform_name = $ipsec2trans_name->{$ipsec};
18600	9	100				13	if ($crypto_type eq 'ASA') {
18601	8	100 100				18	if ($isakmp->{ike_version} == 2) {
18602	2					5	print "$prefix set ikev2 ipsec-proposal $transform_name\n";
18603							}
18604							elsif ($model->{v8_4}) {
18605	2					5	print "$prefix set ikev1 transform-set $transform_name\n";
18606							}
18607							else {
18608	4					9	print "$prefix set transform-set $transform_name\n";
18609							}
18610							}
18611							else {
18612	1					2	print "$prefix set transform-set $transform_name\n";
18613							}
18614
18615	9	50				24	if (my $pfs_group = $ipsec->{pfs_group}) {
18616	9					20	print "$prefix set pfs group$pfs_group\n";
18617							}
18618
18619	9	50				18	if (my $lifetime = $ipsec->{lifetime}) {
18620
18621							# Don't print default value for backend IOS.
18622	9	100	100			24	if (not($lifetime == 3600 and $crypto_type eq 'IOS')) {
18623	8					23	print("$prefix set security-association",
18624							" lifetime seconds $lifetime\n");
18625							}
18626							}
18627	9					12	return;
18628							}
18629
18630							sub print_tunnel_group {
18631	8			8	0	9	my ($name, $interface, $isakmp) = @_;
18632	8					8	my $model = $interface->{router}->{model};
18633	8					8	my $no_nat_set = $interface->{no_nat_set};
18634	8					8	my $authentication = $isakmp->{authentication};
18635	8					18	print "tunnel-group $name type ipsec-l2l\n";
18636	8					14	print "tunnel-group $name ipsec-attributes\n";
18637	8	100				11	if ($authentication eq 'rsasig') {
18638	6					7	my $trust_point = $isakmp->{trust_point};
18639	6	100 100				12	if ($isakmp->{ike_version} == 2) {
18640	2					5	print(" ikev2 local-authentication certificate",
18641							" $trust_point\n");
18642	2					3	print(" ikev2 remote-authentication certificate\n");
18643							}
18644							elsif ($model->{v8_4}) {
18645	2					5	print " ikev1 trust-point $trust_point\n";
18646	2					4	print " ikev1 user-authentication none\n";
18647							}
18648							else {
18649	2					5	print " trust-point $trust_point\n";
18650	2					3	print " isakmp ikev1-user-authentication none\n";
18651							}
18652							}
18653
18654							# Preshared key is configured manually.
18655							else {
18656	2					3	print " peer-id-validate nocheck\n";
18657							}
18658	8					14	return;
18659							}
18660
18661							sub print_ca_and_tunnel_group_map {
18662	6			6	0	5	my ($id, $tg_name) = @_;
18663
18664							# Activate tunnel-group with tunnel-group-map.
18665							# Use $id as ca-map name.
18666	6					13	print "crypto ca certificate map $id 10\n";
18667	6					11	print " subject-name attr ea eq $id\n";
18668	6					14	print "tunnel-group-map $id 10 $tg_name\n";
18669	6					16	return;
18670							}
18671
18672							sub print_static_crypto_map {
18673	5			5	0	8	my ($router, $hardware, $map_name, $interfaces, $ipsec2trans_name) = @_;
18674	5					5	my $model = $router->{model};
18675	5					5	my $crypto_type = $model->{crypto};
18676	5					6	my $hw_name = $hardware->{name};
18677
18678							# Sequence number for parts of crypto map with different peers.
18679	5					5	my $seq_num = 0;
18680
18681							# Crypto ACLs and peer IP must obey NAT.
18682	5					4	my $no_nat_set = $hardware->{no_nat_set};
18683
18684							# Sort crypto maps by peer IP to get deterministic output.
18685	5 2					8 7	my @sorted = sort({ $a->{peers}->[0]->{real_interface}->{ip}
18686							<=>
18687							$b->{peers}->[0]->{real_interface}->{ip}
18688							}
18689							@$interfaces);
18690
18691							# Build crypto map for each tunnel interface.
18692	5					6	for my $interface (@sorted) {
18693	7					7	$seq_num++;
18694	7					15	my $suffix = "$hw_name-$seq_num";
18695
18696	7					8	my $crypto = $interface->{crypto};
18697	7					8	my $ipsec = $crypto->{type};
18698	7					7	my $isakmp = $ipsec->{key_exchange};
18699
18700	7					10	my $crypto_acl_name = print_crypto_acl($interface, $suffix, $crypto,
18701							$crypto_type);
18702	7					11	my $crypto_filter_name = print_crypto_filter_acl($interface, $suffix,
18703							$crypto_type);
18704
18705
18706							# Define crypto map.
18707	7					6	my $prefix;
18708	7	100 50				15	if ($crypto_type eq 'IOS') {
18709	1					2	$prefix = '';
18710	1					8	print "crypto map $map_name $seq_num ipsec-isakmp\n";
18711							}
18712							elsif ($crypto_type eq 'ASA') {
18713	6					14	$prefix = "crypto map $map_name $seq_num";
18714							}
18715
18716							# Set crypto peers.
18717	7	100 50				15	if ($crypto_type eq 'IOS') {
18718	1 1					1 1	for my $peer (@{ $interface->{peers} }) {
18719	1					2	my $peer_ip = prefix_code(address($peer->{real_interface},
18720							$no_nat_set));
18721	1					4	print "$prefix set peer $peer_ip\n";
18722							}
18723							}
18724							elsif ($crypto_type eq 'ASA') {
18725	6					12	print "$prefix set peer ",
18726							join(' ',
18727	6					7	map { prefix_code(address($_->{real_interface},
18728							$no_nat_set)) }
18729	6					8	@{ $interface->{peers} }),
18730							"\n";
18731							}
18732
18733	7					13	print_crypto_map_attributes($prefix, $model, $crypto_type,
18734							$crypto_acl_name, $crypto_filter_name,
18735							$isakmp, $ipsec, $ipsec2trans_name);
18736
18737
18738	7	100				12	if ($crypto_type eq 'ASA') {
18739	6 6					4 11	for my $peer (@{ $interface->{peers} }) {
18740	6					10	my $peer_ip = prefix_code(address($peer->{real_interface},
18741							$no_nat_set));
18742	6					10	print_tunnel_group($peer_ip, $interface, $isakmp);
18743
18744							# Tunnel group needs to be activated, if certificate
18745							# is in use.
18746	6	100				16	if (my $id = $peer->{id}) {
18747	4					6	print_ca_and_tunnel_group_map($id, $peer_ip);
18748							}
18749							}
18750							}
18751							}
18752	5					7	return;
18753							}
18754
18755							sub print_dynamic_crypto_map {
18756	1			1	0	2	my ($router, $hardware, $map_name, $interfaces, $ipsec2trans_name) = @_;
18757	1					1	my $model = $router->{model};
18758	1					2	my $crypto_type = $model->{crypto};
18759	1	50				2	$crypto_type eq 'ASA' or internal_err();
18760	1					2	my $hw_name = $hardware->{name};
18761
18762							# Sequence number for parts of crypto map with different certificates.
18763	1					1	my $seq_num = 65536;
18764
18765							# Sort crypto maps by certificate to get deterministic output.
18766	1 1					2 3	my @sorted = sort({ $a->{peers}->[0]->{id} cmp $b->{peers}->[0]->{id} }
18767							@$interfaces);
18768
18769							# Build crypto map for each tunnel interface.
18770	1					2	for my $interface (@sorted) {
18771	2					2	$seq_num--;
18772	2					5	my $suffix = "$hw_name-$seq_num";
18773	2					4	my $id = $interface->{peers}->[0]->{id};
18774
18775	2					2	my $crypto = $interface->{crypto};
18776	2					2	my $ipsec = $crypto->{type};
18777	2					2	my $isakmp = $ipsec->{key_exchange};
18778
18779	2					4	my $crypto_acl_name = print_crypto_acl($interface, $suffix, $crypto,
18780							$crypto_type);
18781	2					3	my $crypto_filter_name = print_crypto_filter_acl($interface, $suffix,
18782							$crypto_type);
18783
18784							# Define dynamic crypto map.
18785							# Use certificate as name.
18786	2					5	my $prefix = "crypto dynamic-map $id 10";
18787
18788	2					3	print_crypto_map_attributes($prefix, $model, $crypto_type,
18789							$crypto_acl_name, $crypto_filter_name,
18790							$isakmp, $ipsec, $ipsec2trans_name);
18791
18792							# Bind dynamic crypto map to crypto map.
18793	2					5	$prefix = "crypto map $map_name $seq_num";
18794	2					5	print "$prefix ipsec-isakmp dynamic $id\n";
18795
18796							# Use $id as tunnel-group name
18797	2					3	print_tunnel_group($id, $interface, $isakmp);
18798
18799							# Activate tunnel-group with tunnel-group-map.
18800	2					3	print_ca_and_tunnel_group_map($id, $id);
18801							}
18802	1					2	return;
18803							}
18804
18805							sub print_crypto {
18806	248			248	0	228	my ($router) = @_;
18807	248					604	my $model = $router->{model};
18808	248		100			534	my $crypto_type = $model->{crypto} \|\| '';
18809
18810							# List of ipsec definitions used at current router.
18811							# Sort entries by name to get deterministic output.
18812	13					24	my @ipsec = sort by_name unique(
18813	612					1969	map { $_->{crypto}->{type} }
18814	248 248					250 338	grep { $_->{ip} eq 'tunnel' } @{ $router->{interfaces} }
18815							);
18816
18817							# Return if no crypto is used at current router.
18818	248	100				727	return unless @ipsec;
18819
18820							# List of isakmp definitions used at current router.
18821							# Sort entries by name to get deterministic output.
18822	10 13					11 21	my @isakmp = sort by_name unique(map { $_->{key_exchange} } @ipsec);
18823
18824	10					12	my $comment_char = $model->{comment_char};
18825	10					12	print_header($router, 'Crypto');
18826
18827	10	100				19	if ($crypto_type eq 'EZVPN') {
18828	1					3	print_ezvpn $router;
18829	1					3	return;
18830							}
18831
18832							# Use interface access lists to filter incoming crypto traffic.
18833							# Group policy and per-user authorization access list can't be used
18834							# because they are stateless.
18835	9	100				25	if ($crypto_type =~ /^ASA/) {
18836	8					11	print "! VPN traffic is filtered at interface ACL\n";
18837	8					10	print "no sysopt connection permit-vpn\n";
18838							}
18839
18840	9	100				17	if ($crypto_type eq 'ASA_VPN') {
18841	3					7	print_asavpn $router;
18842	3					7	return;
18843							}
18844
18845							# Crypto config for ASA as EZVPN client is configured manually once.
18846							# No config is generated by netspoc.
18847	6	50				8	if ($crypto_type eq 'ASA_EZVPN') {
18848	0					0	return;
18849							}
18850
18851	6	50				20	$crypto_type =~ /^(:?IOS\|ASA)$/
18852							or internal_err("Unexptected crypto type $crypto_type");
18853
18854	6					6	my $isakmp_count = 0;
18855	6					9	for my $isakmp (@isakmp) {
18856
18857							# Only print isakmp for IOS. Approve for ASA will ignore it anyway.
18858	9	100				18	$crypto_type eq 'IOS' or next;
18859
18860	1					2	$isakmp_count++;
18861	1					3	print "crypto isakmp policy $isakmp_count\n";
18862
18863	1					1	my $authentication = $isakmp->{authentication};
18864	1					2	$authentication =~ s/preshare/pre-share/;
18865	1					4	$authentication =~ s/rsasig/rsa-sig/;
18866
18867							# Don't print default value for backend IOS.
18868	1	50				3	if (not($authentication eq 'rsa-sig')) {
18869	0					0	print " authentication $authentication\n";
18870							}
18871
18872	1					2	my $encryption = $isakmp->{encryption};
18873	1	50				5	if ($encryption =~ /^aes(\d+)$/) {
18874	1	50				4	my $len = $crypto_type eq 'ASA' ? "-$1" : " $1";
18875	1					2	$encryption = "aes$len";
18876							}
18877	1					2	print " encryption $encryption\n";
18878	1					2	my $hash = $isakmp->{hash};
18879	1					2	print " hash $hash\n";
18880	1					2	my $group = $isakmp->{group};
18881	1					2	print " group $group\n";
18882
18883	1					1	my $lifetime = $isakmp->{lifetime};
18884
18885							# Don't print default value for backend IOS.
18886	1	50				3	if (not($lifetime == 86400)) {
18887	1					3	print " lifetime $lifetime\n";
18888							}
18889							}
18890
18891							# Handle IPSEC definition.
18892	6					6	my $transform_count = 0;
18893	6					7	my %ipsec2trans_name;
18894	6					7	for my $ipsec (@ipsec) {
18895	9					7	$transform_count++;
18896	9					15	my $transform_name = "Trans$transform_count";
18897	9					12	$ipsec2trans_name{$ipsec} = $transform_name;
18898	9					10	my $isakmp = $ipsec->{key_exchange};
18899
18900							# IKEv2 syntax for ASA.
18901	9	100	100			30	if ($crypto_type eq 'ASA' and $isakmp->{ike_version} == 2) {
18902	2					5	print "crypto ipsec ikev2 ipsec-proposal $transform_name\n";
18903	2	50				11	if (my $ah = $ipsec->{ah}) {
18904	0					0	print " protocol ah $ah\n";
18905							}
18906	2					2	my $esp_encr;
18907	2	50 50 50				16	if (not(my $esp = $ipsec->{esp_encryption})) {
18908	0					0	$esp_encr = 'null';
18909							}
18910							elsif ($esp =~ /^(aes\|des\|3des)$/) {
18911	0					0	$esp_encr = $1;
18912							}
18913							elsif ($esp =~ /^aes(192\|256)$/) {
18914	2					4	$esp_encr = "aes-$1";
18915							}
18916	2					4	print " protocol esp encryption $esp_encr\n";
18917	2	50				5	if (my $esp_ah = $ipsec->{esp_authentication}) {
18918	2					9	$esp_ah =~ s/^(.+?)(\d+)/$1-$2/;
18919	2					9	print " protocol esp integrity $esp_ah\n";
18920							}
18921							}
18922
18923							# IKEv1 syntax of ASA is identical to IOS.
18924							else {
18925	7					11	my $transform = '';
18926	7	50				10	if (my $ah = $ipsec->{ah}) {
18927	0					0	$transform .= "ah-$ah-hmac ";
18928							}
18929	7	50 100 50				41	if (not(my $esp = $ipsec->{esp_encryption})) {
18930	0					0	$transform .= 'esp-null ';
18931							}
18932							elsif ($esp =~ /^(aes\|des\|3des)$/) {
18933	3					7	$transform .= "esp-$1 ";
18934							}
18935							elsif ($esp =~ /^aes(192\|256)$/) {
18936	4	100				10	my $len = $crypto_type eq 'ASA' ? "-$1" : " $1";
18937	4					9	$transform .= "esp-aes$len ";
18938							}
18939	7	50				18	if (my $esp_ah = $ipsec->{esp_authentication}) {
18940	7					12	$transform .= "esp-$esp_ah-hmac";
18941							}
18942	7	100	100			24	my $prefix = ($crypto_type eq 'ASA' and $model->{v8_4})
18943							? 'crypto ipsec ikev1'
18944							: 'crypto ipsec';
18945	7					26	print "$prefix transform-set $transform_name $transform\n";
18946							}
18947							}
18948
18949							# Collect tunnel interfaces attached to each hardware interface.
18950							# Differentiate on peers having static or dynamic IP address.
18951	6					7	my %hardware2crypto;
18952							my %hardware2dyn_crypto;
18953	6 6					5 9	for my $interface (@{ $router->{interfaces} }) {
18954	21	100				36	$interface->{ip} eq 'tunnel' or next;
18955	9					13	my $ip = $interface->{peers}->[0]->{real_interface}->{ip};
18956	9	100				20	if ($ip =~ /^(?:negotiated\|short\|unnumbered)$/) {
18957	2 2					3 5	push @{ $hardware2dyn_crypto{ $interface->{hardware} } }, $interface;
18958							}
18959							else {
18960	7 7					3 21	push @{ $hardware2crypto{ $interface->{hardware} } }, $interface;
18961							}
18962							}
18963
18964	6 6					6 10	for my $hardware (@{ $router->{hardware} }) {
18965	12					11	my $hw_name = $hardware->{name};
18966
18967							# Name of crypto map.
18968	12					13	my $map_name = "crypto-$hw_name";
18969
18970	12					12	my $have_crypto_map;
18971	12	100				22	if (my $interfaces = $hardware2crypto{$hardware}) {
18972	5					11	print_static_crypto_map($router, $hardware, $map_name, $interfaces,
18973							\%ipsec2trans_name);
18974	5					4	$have_crypto_map = 1;
18975							}
18976	12	100				23	if (my $interfaces = $hardware2dyn_crypto{$hardware}) {
18977	1					2	print_dynamic_crypto_map($router, $hardware, $map_name, $interfaces,
18978							\%ipsec2trans_name);
18979	1					1	$have_crypto_map = 1;
18980							}
18981
18982							# Bind crypto map to interface.
18983	12	100				22	$have_crypto_map or next;
18984	6	100 50				13	if ($crypto_type eq 'IOS') {
18985	1 1					1 4	push(@{ $hardware->{subcmd} }, "crypto map $map_name");
18986							}
18987							elsif ($crypto_type eq 'ASA') {
18988	5					19	print "crypto map $map_name interface $hw_name\n";
18989							}
18990							}
18991	6					23	return;
18992							}
18993
18994							sub print_interface {
18995	248			248	0	224	my ($router) = @_;
18996	248					256	my $model = $router->{model};
18997	248	100				523	return if !$model->{print_interface};
18998	122					134	my $class = $model->{class};
18999	122					151	my $stateful = not $model->{stateless};
19000	122 122					115 174	for my $hardware (@{ $router->{hardware} }) {
19001	291					312	my $name = $hardware->{name};
19002	291	100	67			515	next if $name eq 'VIP' and $model->{has_vip};
19003	289					227	my @subcmd;
19004							my $secondary;
19005	0					0	my $addr_cmd;
19006	289 289					224 357	for my $intf (@{ $hardware->{interfaces} }) {
19007	319					312	my $ip = $intf->{ip};
19008	319	50 100 100 100				847	if ($ip eq 'tunnel') {
19009	0					0	next;
19010							}
19011							elsif ($ip eq 'unnumbered') {
19012	4					5	$addr_cmd = 'ip unnumbered X';
19013							}
19014							elsif ($ip eq 'negotiated') {
19015	1					1	$addr_cmd = 'ip address negotiated';
19016							}
19017							elsif ($model->{use_prefix}) {
19018	37					46	my $addr = print_ip($ip);
19019	37					61	my $mask = mask2prefix($intf->{network}->{mask});
19020	37					63	$addr_cmd = "ip address $addr/$mask";
19021	37	100				70	$addr_cmd .= ' secondary' if $secondary;
19022							}
19023							else {
19024	277					338	my $addr = print_ip($ip);
19025	277					420	my $mask = print_ip($intf->{network}->{mask});
19026	277					438	$addr_cmd = "ip address $addr $mask";
19027	277	100				472	$addr_cmd .= ' secondary' if $secondary;
19028							}
19029	319					307	push @subcmd, $addr_cmd;
19030	319					456	$secondary = 1;
19031							}
19032	289	100				517	if (my $vrf = $router->{vrf}) {
19033	4	50				6	if ($class eq 'NX-OS') {
19034	4					5	push @subcmd, "vrf member $vrf";
19035							}
19036							else {
19037	0					0	push @subcmd, "ip vrf forwarding $vrf";
19038							}
19039							}
19040
19041							# Add "ip inspect" as marker, that stateful filtering is expected.
19042							# The command is known to be incomplete, "X" is only used as
19043							# placeholder.
19044	289	100	100			1172	if ($class eq 'IOS' && $stateful && !$hardware->{loopback}) {
19045	167					161	push @subcmd, "ip inspect X in";
19046							}
19047	289	100				469	if (my $other = $hardware->{subcmd}) {
19048	270					271	push @subcmd, @$other;
19049							}
19050
19051							# Split name for ACE: "vlan3029" -> "vlan 3029"
19052	289	100				469	$name =~ s/(\d+)/ $1/ if ($class eq 'ACE');
19053
19054	289					535	print "interface $name\n";
19055	289					342	for my $cmd (@subcmd) {
19056	775					1572	print " $cmd\n";
19057							}
19058							}
19059	122					150	print "\n";
19060	122					226	return;
19061							}
19062
19063							# Make output directory available.
19064							sub check_output_dir {
19065	310			310	0	308	my ($dir) = @_;
19066	310	50				1249	unless (-e $dir) {
19067	0	0				0	mkdir $dir
19068							or fatal_err("Can't create output directory $dir: $!");
19069							}
19070	310	50				792	-d $dir or fatal_err("$dir isn't a directory");
19071	310					322	return;
19072							}
19073
19074							# Print generated code for each managed router.
19075							sub print_code {
19076	155			155	0	184	my ($dir) = @_;
19077
19078							# Untaint $dir. This is necessary if running setuid.
19079							# We can trust value of $dir because it is set by setuid wrapper.
19080	155					515	($dir) = ($dir =~ /(.*)/);
19081	155					276	check_output_dir($dir);
19082
19083	155					201	progress('Printing code');
19084	155					128	my %seen;
19085	155					206	for my $router (@managed_routers, @routing_only_routers) {
19086	261	100				543	next if $seen{$router};
19087
19088							# Ignore splitted part.
19089	258	100				430	next if $router->{orig_router};
19090
19091	249					313	my $device_name = $router->{device_name};
19092	249					211	my $file = $device_name;
19093
19094							# Untaint $file. It has already been checked for word characters,
19095							# but check again for the case of a weird locale setting.
19096	249					545	$file =~ /^(.*)/;
19097	249					602	$file = "$dir/$1";
19098
19099							## no critic (RequireBriefOpen)
19100	249	50				6126	open(my $code_fd, '>', $file)
19101							or fatal_err("Can't open $file for writing: $!");
19102	249					670	select $code_fd;
19103
19104	249					334	my $model = $router->{model};
19105	249					274	my $comment_char = $model->{comment_char};
19106
19107							# Restore interfaces of splitted router.
19108	249	100				443	if (my $orig_interfaces = $router->{orig_interfaces}) {
19109	9					10	$router->{interfaces} = $orig_interfaces;
19110	9					14	$router->{hardware} = $router->{orig_hardware};
19111							}
19112
19113							# Collect VRF members.
19114	249					185	my $vrf_members;
19115	249	100				394	if (my $members = $router->{vrf_members}) {
19116	3					5	$vrf_members = $members;
19117	3					14	$seen{$_} = 1 for @$members;
19118							}
19119							else {
19120	246					360	$vrf_members = [ $router ];
19121							}
19122
19123	249					2036	print "$comment_char Generated by $program, version $version\n\n";
19124	249					571	print "$comment_char [ BEGIN $device_name ]\n";
19125	249					489	print "$comment_char [ Model = $model->{class} ]\n";
19126	249	100				439	if ($router->{policy_distribution_point}) {
19127	7 7 7	50				11 9 22	my @ips = map({ my $ips = $_->{admin_ip}; $ips ? @$ips : (); }
19128							@$vrf_members);
19129	7	50				16	if (@ips) {
19130	7					48	printf("$comment_char [ IP = %s ]\n", join(',', @ips));
19131							}
19132							}
19133							my $per_vrf = sub {
19134	1233			1233		1060	my($call) = @_;
19135	1233					1292	for my $vrouter (@$vrf_members) {
19136	1244					1546	$call->($vrouter);
19137							}
19138	249					803	};
19139	249	100				407	if ($router->{managed}) {
19140	246					427	$per_vrf->(\&print_routes);
19141	246					438	$per_vrf->(\&print_crypto);
19142	246					422	print_acl_prefix($router);
19143	246					364	$per_vrf->(\&print_acls);
19144	246					390	print_acl_suffix($router);
19145	246					377	$per_vrf->(\&print_interface);
19146	246					387	$per_vrf->(\&print_nat);
19147							}
19148							else {
19149	3					5	$per_vrf->(\&print_routes);
19150							}
19151
19152	249					566	print "$comment_char [ END $device_name ]\n\n";
19153	249					310	select STDOUT;
19154	249	50				5839	close $code_fd or fatal_err("Can't close $file: $!");
19155							## use critic
19156
19157							}
19158	155					255	return;
19159							}
19160
19161							sub copy_raw {
19162	155			155	0	224	my ($in_path, $out_dir) = @_;
19163	155	50	33			939	return if ! (defined $in_path && -d $in_path);
19164	155	50				247	return if ! defined $out_dir;
19165
19166							# Untaint $in_path, $out_dir. This is necessary if running setuid.
19167							# Trusted because set by setuid wrapper.
19168	155					515	($in_path) = ($in_path =~ /(.*)/);
19169	155					319	($out_dir) = ($out_dir =~ /(.*)/);
19170	155					232	check_output_dir($out_dir);
19171
19172	155					236	my $raw_dir = "$in_path/raw";
19173	155	50				840	return if not -d $raw_dir;
19174
19175							# Clean PATH if run in taint mode.
19176							## no critic (RequireLocalizedPunctuationVars)
19177	0					0	$ENV{PATH} = '/usr/local/bin:/usr/bin:/bin';
19178							## use critic
19179
19180	0					0	my %device_names =
19181	0					0	map { $_->{device_name} => 1 } @managed_routers, @routing_only_routers;
19182
19183	0	0				0	opendir(my $dh, $raw_dir) or fatal_err("Can't opendir $raw_dir: $!");
19184	0					0	while (my $file = Encode::decode($filename_encode, readdir $dh)) {
19185	0	0				0	next if $file =~ /^\./;
19186	0	0				0	next if $file =~ m/$config{ignore_files}/o;
19187
19188							# Untaint $file.
19189	0					0	my ($raw_file) = ($file =~ /^(.*)/);
19190	0					0	my $raw_path = "$raw_dir/$raw_file";
19191	0	0				0	if (not -f $raw_path) {
19192	0					0	warn_msg("Ignoring $raw_path");
19193	0					0	next;
19194							}
19195	0	0				0	if (not $device_names{$file}) {
19196	0					0	warn_msg("Found unused $raw_path");
19197	0					0	next;
19198							}
19199	0					0	my $copy = "$out_dir/$raw_file.raw";
19200	0	0				0	system("cp -f $raw_path $copy") == 0
19201							or fatal_err("Can't copy $raw_path to $copy: $!");
19202							}
19203	0					0	return;
19204							}
19205
19206							sub show_version {
19207	318			318	0	753	progress("$program, version $version");
19208	318					298	return;
19209							}
19210
19211							sub show_finished {
19212	208	50		208	0	381	progress('Finished') if $config{time_stamps};
19213	208					177	return;
19214							}
19215
19216							# These must be initialized on each run, because protocols are changed
19217							# by prepare_prt_ordering.
19218							sub init_protocols {
19219
19220	375			375	0	1229	%routing_info = (
19221							EIGRP => {
19222							name => 'EIGRP',
19223							prt => { name => 'auto_prt:EIGRP', proto => 88 },
19224							mcast => [
19225							new(
19226							'Network',
19227							name => "auto_network:EIGRP_multicast",
19228							ip => gen_ip(224, 0, 0, 10),
19229							mask => gen_ip(255, 255, 255, 255)
19230							)
19231							]
19232							},
19233							OSPF => {
19234							name => 'OSPF',
19235							prt => { name => 'auto_prt:OSPF', proto => 89 },
19236							mcast => [
19237							new(
19238							'Network',
19239							name => "auto_network:OSPF_multicast5",
19240							ip => gen_ip(224, 0, 0, 5),
19241							mask => gen_ip(255, 255, 255, 255),
19242							),
19243							new(
19244							'Network',
19245							name => "auto_network:OSPF_multicast6",
19246							ip => gen_ip(224, 0, 0, 6),
19247							mask => gen_ip(255, 255, 255, 255)
19248							)
19249							]
19250							},
19251							dynamic => { name => 'dynamic' },
19252
19253							# Identical to 'dynamic', but must only be applied to router.
19254							manual => { name => 'manual' },
19255							);
19256	375					1159	%xxrp_info = (
19257							VRRP => {
19258							prt => { name => 'auto_prt:VRRP', proto => 112 },
19259							mcast => new(
19260							'Network',
19261							name => "auto_network:VRRP_multicast",
19262							ip => gen_ip(224, 0, 0, 18),
19263							mask => gen_ip(255, 255, 255, 255)
19264							)
19265							},
19266							HSRP => {
19267							prt => {
19268							name => 'auto_prt:HSRP',
19269							proto => 'udp',
19270							dst_range => [ 1985, 1985 ],
19271							},
19272							mcast => new(
19273							'Network',
19274							name => "auto_network:HSRP_multicast",
19275							ip => gen_ip(224, 0, 0, 2),
19276							mask => gen_ip(255, 255, 255, 255)
19277							)
19278							},
19279							HSRPv2 => {
19280							prt => {
19281							name => 'auto_prt:HSRPv2',
19282							proto => 'udp',
19283							dst_range => [ 1985, 1985 ],
19284							},
19285							mcast => new(
19286							'Network',
19287							name => "auto_network:HSRPv2_multicast",
19288							ip => gen_ip(224, 0, 0, 102),
19289							mask => gen_ip(255, 255, 255, 255)
19290							)
19291							},
19292							);
19293
19294	375					836	$prt_ip = { name => 'auto_prt:ip', proto => 'ip' };
19295	375					578	$prt_icmp = {
19296							name => 'auto_prt:icmp',
19297							proto => 'icmp'
19298							};
19299	375					806	$prt_tcp = {
19300							name => 'auto_prt:tcp',
19301							proto => 'tcp',
19302							dst_range => $aref_tcp_any
19303							};
19304	375					732	$prt_udp = {
19305							name => 'auto_prt:udp',
19306							proto => 'udp',
19307							dst_range => $aref_tcp_any
19308							};
19309	375					869	$prt_bootps = {
19310							name => 'auto_prt:bootps',
19311							proto => 'udp',
19312							dst_range => [ 67, 67]
19313							};
19314	375					1082	$prt_ike = {
19315							name => 'auto_prt:IPSec_IKE',
19316							proto => 'udp',
19317							src_range => [ 500, 500 ],
19318							dst_range => [ 500, 500 ]
19319							};
19320	375					1130	$prt_natt = {
19321							name => 'auto_prt:IPSec_NATT',
19322							proto => 'udp',
19323							src_range => [ 4500, 4500 ],
19324							dst_range => [ 4500, 4500 ]
19325							};
19326	375					748	$prt_esp = { name => 'auto_prt:IPSec_ESP', proto => 50, prio => 100, };
19327	375					707	$prt_ah = { name => 'auto_prt:IPSec_AH', proto => 51, prio => 99, };
19328	375					801	$deny_any_rule = {
19329							deny => 1,
19330							src => $network_00,
19331							dst => $network_00,
19332							prt => $prt_ip
19333							};
19334	375					634	$permit_any_rule = {
19335							src => $network_00,
19336							dst => $network_00,
19337							prt => $prt_ip
19338							};
19339	375					505	return;
19340							}
19341
19342							sub init_global_vars {
19343	375			375	0	813	$start_time = time();
19344	375					344	$error_counter = 0;
19345	375					343	$abort_immediately = undef;
19346	375					320	$new_store_description = 0;
19347	375					837	for my $pair (values %global_type) {
19348	4875 4875					3331 6494	%{ $pair->[1] } = ();
19349							}
19350	375					824	%interfaces = %hosts = ();
19351	375					578	@managed_routers = @routing_only_routers = @router_fragments = ();
19352	375					525	@virtual_interfaces = @pathrestrictions = ();
19353	375					730	@managed_crypto_hubs = @routers = @networks = @zones = @areas = ();
19354	375					365	@natdomains = ();
19355	375					375	%auto_interfaces = ();
19356	375					348	$from_json = undef;
19357	375					537	%crypto2spokes = %crypto2hubs = ();
19358	375					371	%rule_tree = ();
19359	375					8419	%prt_hash = %ref2prt = %ref2obj = %token2regex = ();
19360	375					438	%ref2obj = %ref2prt = ();
19361	375					385	%obj2zone = ();
19362	375					366	%obj2path = ();
19363	375					341	%key2obj = ();
19364	375					353	%border2obj2auto = ();
19365	375					351	%filter_networks = ();
19366	375					344	@deleted_rules = ();
19367	375					451	%unknown2services = %unknown2unknown = ();
19368	375					413	%supernet_rule_tree = %missing_supernet = ();
19369	375					361	%smaller_prt = ();
19370	375					409	%known_log = %key2log = ();
19371	375					537	init_protocols();
19372	375					419	return;
19373							}
19374
19375							# Call once when module is loaded.
19376							# Call again, before different input is processed by same instance.
19377							init_global_vars();
19378
19379							####################################################################
19380							# Argument processing
19381							# Get option names from %config.
19382							# Write options back to %config.
19383							####################################################################
19384
19385	70 70 70			70		25307 114 361	use Getopt::Long qw(GetOptionsFromArray);
19386	70 70 70			70		15783 126 62673	use Pod::Usage;
19387
19388							sub parse_options {
19389	305			305	0	260	my ($args) = @_;
19390	305					245	my %result;
19391							my $setopt = sub {
19392	3			3		3	my ($key, $val) = @_;
19393	3	50				6	if (my $expected = check_config_pair($key, $val)) {
19394	0					0	die "Value '$val' invalid for option $key ($expected expected)\n";
19395							}
19396	3					9	$result{$key} = $val;
19397	305					1180	};
19398
19399	305					287	my %options;
19400	305					429	for my $key (get_config_keys()) {
19401	5185	100				5887	my $opt = get_config_pattern($key) eq '0\|1' ? '!' : '=s';
19402	5185					9188	$options{"$key$opt"} = $setopt;
19403							}
19404	305 305			305		1147 675	$options{quiet} = sub { $result{verbose} = 0 };
19405	305 0			0		670 0	$options{'help\|?'} = sub { pod2usage(1) };
19406	305 0			0		642 0	$options{man} = sub { pod2usage(-exitstatus => 0, -verbose => 2) };
19407
19408	305	50				1506	if (!GetOptionsFromArray($args, %options)) {
19409
19410							# Don't use 'exit' but 'die', so we can catch this error in tests.
19411	0					0	my $out;
19412	0	0				0	open(my $fh, '>', \$out) or die $!;
19413	0					0	pod2usage(-exitstatus => 'NOEXIT', -verbose => 0, -output => $fh);
19414	0					0	close $fh;
19415	0		0			0	die($out \|\| '');
19416							}
19417
19418	305					2711	return \%result;
19419							}
19420
19421							sub parse_args {
19422	305			305	0	279	my ($args) = @_;
19423	305					350	my $main_file = shift @$args;
19424
19425							# Strip trailing slash for nicer messages.
19426	305	50				673	defined $main_file and $main_file =~ s</$><>;
19427
19428							# $out_dir is used to store compilation results.
19429							# For each managed router with name X a corresponding file X
19430							# is created in $out_dir.
19431							# If $out_dir is missing, all code is printed to STDOUT.
19432	305					274	my $out_dir = shift @$args;
19433
19434							# Strip trailing slash for nicer messages.
19435	305	100				493	defined $out_dir and $out_dir =~ s</$><>;
19436
19437							# No further arguments allowed.
19438	305	50				460	@$args and pod2usage(2);
19439	305					534	return ($main_file, $out_dir);
19440							}
19441
19442							sub compile {
19443	305			305	0	289	my ($args) = @_;
19444
19445	305					478	my($cmd_config) = &parse_options($args);
19446	305					507	my($in_path, $out_dir) = &parse_args($args);
19447	305					494	my $file_config = &read_config($in_path);
19448
19449							# Command line options override options from 'config' file.
19450							# Rightmost overrides.
19451	305					501	&set_config($file_config, $cmd_config);
19452
19453							# Don't compile but check only for errors if no $out_dir is given.
19454	305					420	&fast_mode(!$out_dir);
19455	305					421	&show_version();
19456	305					427	&read_file_or_dir($in_path);
19457	305					424	&show_read_statistics();
19458	305					412	&order_protocols();
19459	305					422	&link_topology();
19460	305					441	&mark_disabled();
19461	305					464	&set_zone();
19462	305					441	&setpath();
19463	300					422	&distribute_nat_info();
19464	300					437	find_subnets_in_zone();
19465	300					398	&set_service_owner();
19466	300					436	&expand_services(1); # 1: expand hosts to subnets
19467
19468							# Abort now, if there are syntax errors and simple semantic errors.
19469	300					414	&abort_on_error();
19470	226					327	&expand_crypto();
19471	226					305	&check_unused_groups();
19472	226					641	set_policy_distribution_ip();
19473	226					363	&optimize_and_warn_deleted();
19474	226					321	&check_supernet_rules();
19475	226					325	prepare_nat_commands();
19476	226					372	find_active_routes();
19477	226					330	&gen_reverse_rules();
19478	226					327	&mark_secondary_rules();
19479	226					296	mark_dynamic_nat_rules();
19480	226					292	&abort_on_error();
19481	208					276	&set_abort_immediately();
19482	208					299	&rules_distribution();
19483	208					318	&local_optimization();
19484	208	100				351	if ($out_dir) {
19485	155					263	&print_code($out_dir);
19486	155					253	copy_raw($in_path, $out_dir);
19487							}
19488	208					297	show_finished();
19489	208					546	return;
19490							}
19491
19492							1;
19493
19494							# LocalWords: Netspoc Knutzen internet CVS IOS iproute iptables STDERR Perl
19495							# LocalWords: netmask EOL ToDo IPSec unicast utf hk src dst ICMP IPs EIGRP
19496							# LocalWords: OSPF VRRP HSRP Arnes loop's ISAKMP stateful ACLs negatable
19497							# LocalWords: STDOUT